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1.  INTRODUCTION 


The  disturbance  generated  by  a moving  submerged  body  in  a stratified 
ocean  can  be  separated,  under  realistic  ocean  conditions,  according  to  the 
distinct  physical  phenomena  responsible  for  propagating  the  disturbance. 
Because,  at  best,  the  ocean  is  weakly  stratified,  there  is  a region  near 
the  body  in  which  inertia  and  pressure  dominate  over  buoyant  restoring 
forces  at  all  but  very  low  body  velocities.  This  can  be  calculated  with- 
out considering  the  (weak  in  this  region)  effect  of  density  stratification, 
and  will  be  termed  the  potential  disturbance.  Sufficiently  far  from  the 
body,  the  inertia  and  pressure  disturbances  become  small  and  buoyant  re- 
storing forces  become  significant,  so  that  the  disturbance  takes  the  form, 
predominantly,  of  internal  waves  in  the  stratified  ocean.  These  internal 
waves  can  be  excited  by  the  displacement  effect  of  the  body  (which,  of 
course,  also  drives  the  less  persistent  potential  disturbance),  but  in 
addition,  they  can  be  excited  by  the  "collapse"  of  the  turbulent  wake  of 
the  body.  The  dynamics  of  this  wake  are  dominated,  close  to  the  body,  by 
inertia  and  diffusion.  Farther  away,  inertia,  pressure  and  buoyant  restor- 
ing forces  dominate.  The  region  in  which  diffusion  becomes  unimportant 
can  be  termed  the  start  of  collapse,  since  buoyant  restoring  forces  will 
then  start  to  flatten  the  wake,  whose  density  distribution  has  been  changed 
by  turbulent  mixing,  toward  a shape  consistent  with  static  density  equilib- 
rium, generating  internal  waves  in  the  process. 

The  purpose  of  this  study  has  been  to  develop  a code  capable  of  com- 
puting these  disturbances  with  emphasis  on  optimizing  the  speed,  simplicity 
and  versatility  of  the  code  to  make  it  suitable  for  engineering  studies 
involving  large  numbers  of  individual  calculations.  The  present  report 
describes  the  operation  of  the  resulting  code,  which  is  indeed  quite  versa- 
tile. The  cost  of  this  versatility  is,  as  always,  an  unavoidable  complexity. 
The  complete  capabilities  of  the  code  are  described  in  the  following  sections, 
but  it  is  not  reasonable  to  expect  a new  user,  immediately  on  reading  this 
description,  to  generate  the  da:a  set  required  to  run  a specific  calculation. 


It  is  recommended,  rather,  that  the  new  user  start  by  becoming  thoroughly 
familiar  with  volumes  1-3  of  this  series,  which  describe  the  analytical 
basis  for  the  code  before  reading  further  in  the  present  report.  The  first 
few  cases  run  should  follow  the  format  of  one  of  the  sample  calculations 
presented  here,  before  the  user  attempts  to  invoke  one  of  the  almost 
limitless  variations  thereof. 
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2.  PROGRAM  CAPABILITIES 


SEEK  is  a Fortran  IV  program  which  runs  on  the  CDC  6000  series  com- 
puters. It  simulates  the  internal  waves  generated  by  various  sources 
moving  horizontally  through  a vertically  stratified  ocean.  A detailed 
description  of  the  problem  and  the  technical  approach  is  contained  in 
references  1-3.  The  capabilities  of  the  program  are  briefly  outlined 
below . 


Ocean  description: 

o up  to  400  points  in  thermocline  table 

• variable  spacing  in  thermocline  table 

• table  covers  only  thermocline,  not  unstratified  regions 

• up  to  80  modes 

Source  models: 

• Rankine  or  dipole  body 

«*  oval  or  circular  cross-section  superstructure 

• wake  collapse 

Disturbance  calculation: 

• select  from  10  variables  vcross-track  velocity,  vertical 
displacement,  etc.) 

• potential  flow  solutions  for  Rankine  body,  oval  superstructure 

• Fourier  transforms  by  FFT  algorithm  for  near  field 

- select  x-y  or  z-y  grid  pattern 

- up  to  256  point  transform  (unaliased) 

- mode  range  of  up  to  40 

• Fourier  transforms  by  stationary  phase  approximation  for  far  field 

- select  x-y,  z-y  or  z-x  grid  pattern 

- up  to  800  points  per  cut 

- mode  range  of  up  to  41 


Input 

• data  library  capability 

• save  and  use  processed  ocean  data  (compute  eigenvalues  only  once) 

• free  form  input  (Namelist) 
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3.  OVERVIEW  OF  PROGRAM  OPERATION 


The  SEEK  program  consists  of  five  major  modules  as  illustrated  in 
Figure  1.  Figure  2 diagrams  the  program  files  which  are  manageable  by 
the  user. 

At  the  start  of  execution,  the  program  transfers  control  to  the 
input  processor  which  reads  the  first  card  of  the  data  deck  from  the 
INPUT  file.  This  card  is  an  "input  processor  control  card"  (IPCC) . An 
IPCC  (depending  on  its  type)  may  direct  the  input  processor  to 

1.  read  data  from  the  data  deck  (file  INPUT), 

2.  read  data  from  the  data  library  (file  TAPEl), 

3.  interrupt  the  input  sequence  and  execute  the  data  read  in, 

4.  terminate  the  program. 

Typically,  several  sets  of  data  are  read  from  files  INPUT  and  TAPEl 
before  the  input  sequence  is  interrupted.  When  an  IPCC  of  type  3 is 
read,  the  input  processor  examines  selected  variables,  noting  which  of 
them  were  changed  during  the  input  sequence.  The  input  processor  then 
returns  control  to  the  main  program.  * 

The  dispersion  table  generator  performs  its  function  based  on  the 
options  selected  and  available  data.  The  first  case  of  a run  presents 
two  possibilities. 

1.  The  dispersion  tables  are  constructed  entirely  from  data  read 
by  the  input  processor. 

2.  The  dispersion  tables  are  constructed  using  both  input  data  and 
"processed  ocean"  data  from  file  TAPE2 . 

Every  time  item  1 holds,  the  program  writes  the  new  processed  ocean  data 
on  file  TAPE2.  If  this  file  is  saved  at  the  end  of  the  run,  it  can  be 
restored  and  used  in  a subsequent  run.  Substantial  savings  can  be  realized 
by  using  processed  ocean  data. 

Processed  ocean  data  are  used  only  for  the  first  case  of  a run.  It  is 
assumed  (but  not  required)  that  each  subsequent  case  is  a more  or  less 
minor  variation  of  the  preceding  case.  Accordingly,  the  dispersion  table 
generator  uses  results  from  the  preceding  case  whenever  possible.  The 
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TAPE9,TAPE10 


1 Program  / 


print/plot  data 


User-manageable  files. 
Scratch  files  are  not  shown 


1 

Output 

TAPE50 

print  file  | 

plot  file 

TAPEl 

TAPE2 

data  library 

■ V 

processed  ocean 
1 

elements  which  must  be  recomputed  are  determined  by  examining  the  "change 
notices"  generated  by  the  input  processor. 


The  dispersion  table  generator  allows  for  the  print/plot  of  a selected 
eigenvector . 


The  grid  computations  are  performed  by  one  of  two  modules  selected  by 
an  input  option. 


1. 


Near  field; fast  Fourier  transform  (FFT)  and/or  potential  solutions. 
Two  grid  patterns  are  available,  an  x-y  grid  and  a z-y  grid.  Note 
that,  for  instance,  an  x-y  grid  produces  a vector  at  each  value  of 


where  the  components  of  the  vector  are  the  signal  ('disturbance 

i • -r  r _ Tirim  ^ 


variable)  values  at  the  various  y coordinates.  If  the  pFT  option 
is  used,  it  is  also  possible  to  print  the  dispersion  tables,  print 
plot  the  individual  dispersion  variables  and  print/plot  the  power 
spectra.  If  only  the  potential  flow  solution  is  used,  the  disper- 
sion relation  computations  are  avoided.  If  both  options  are  on, 
the  resulting  signal  is  the  superposition  of  the  two. 


2. 


Far  field: stationary  phase  solution.  Three  grid  patterns  are 
available  --  an  x-y,  a z-y  and  a z-x  grid.  It  is  possible  to 
print  the  dispersion  tables,  print  the  wave  family  edge  table, 
and  print/plot  the  individual  dispersion  variables. 


In  both  modules,  if  a grid  is  specified,  the  signal  data  are  automati- 
cally sent  to  the  print/plot  processor.  It  should  be  noted  that  a grid 
involving  multiple  depths  is  significantly  slower  in  execution  than  an  x-y  grid 


The  print/plot  (PP)  processor  is  a generalized  module  for  data  dis- 
play. All  data  destined  for  the  PP  processor  are  written  on  files  TAPE^  and 
TAPE10.  TAPE9  has  the  actual  data  while  TAPElO  has  format,  scaling  and 
file  structure  information.  In  writing  these  files,  the  program  provides 
a preset  format  in  which  to  display  the  data.  This  format  may  vary  accord- 
ing to  the  type  of  information  being  written.  For  each  set  of  data  on  the 
files,  the  user  may  override  the  preset  format,  specifying  no  display,  a 
display  window,  print  only,  plot  only,  plot  scaling,  etc. 


Generally,  data  generated  during  the  computational  phase  of  a case  are 
displayed  at  the  end  of  that  case.  The  PP  data  files  are  then  rewound  and 
PP  data  for  the  next  case  are  written  over  the  old  data.  However,  it  is 
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possible  to  accumulate  data  for  multiple  cases  on  tne  PP  data  files  ard 
produce  all  the  displays  at  the  end  of  the  last  CAse  (note  that  it  is 
easy  to  produce  rather  large  data  files  in  this  way).  Whether  the  files 
contain  all  the  data  or  just  data  for  the  last  case,  it  may  be  desirable 
to  "ave  them  at  the  end  of  the  run.  Then  the  displays  can  be  examined 
and,  if  appropriate,  another  run  can  be  made  to  display  the  saved  data  in 


a different  format. 
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4.  DATA  DECK  STRUCTURE 


The  "data  deck"  is  a set  of  source  cards  which  the  program  reads  from 
the  INPUT  file.  The  reading  of  data  and  its  execution  are  governed  by  "input 
processor  control  cards"  (IPCCs)  which  are  contained  within  the  data  deck. 

In  addition  to  IPCCs,  the  data  deck  may  contain  "data  sets".  A data 
set  is  defined  as  all  the  cards  read  when  a single  namelist  read  is  executed. 
Note  that  namelist  input  is  a system  function;  syntax  rules  for  entering 
namelist  data  may  be  found  in  the  Fortran  manual.  Generally,  a data  set 
starts  with  a $ in  column  2,  followed  by  a namelist  name,  followed  by  data 
(which  may  extend  over  several  cards),  and  is  terminated  by  another  $.  Sev- 
eral namelist  input  sets  have  been  implemented  in  the  program.  These  namelist 
sets  categorize  the  data  as  described  in  Figure  3. 


Namelist 

Name 

Data  1 
Type 

General  Description  of  Data 

0CEAN 

0 

Ocean  description  and  dispersion  table 
specif i cation 

SOURCE 

S 

Source  model  selection  and  description 

GRID 

G 

Grid  definition 

P1’ 

: 

P 

(Print/plot)  editing  specifications  for 
output  display 

Figure  3.  Input  data  classification 
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There  are  four  different  IPCCs.  They  are  all  fixed  field  cards 
which  start  in  column  1.  They  have  no  embedded  blanks  except  possibly 
for  the  "id"  field. 


IPCC 


INP,  t 


Description 


LIB, t, id 


This  card  instructs  the  program  to  read  a data  set  of  data 
type  "t"  from  the  data  deck.  The  "data  type"  is  a one 
character  code  defined  in  Figure  3.  The  data  set  must 
immediately  follow  this  card.  Any  data  set  in  the  data 
deck  must  be  preceded  by  this  card. 


This  card  instructs  the  program  to  read  a data  set  of  data 
type  "t"  with  identifier  "id"  from  the  data  library  file. 

The  "data  type"  is  a one  character  code  defined  in  Figure 
3.  "id"  is  a 10  character  identifier  used  to  locate  the 
desired  data  set  in  the  data  library  file.  The  data  library] 
is  described  in  Figure  5. 


Note  that  if  a given  data  type  appears  more  than  once  on  the  above 
cards,  the  current  data  set  is  overlaid  on  top  of  the  previous  data 
set (s) , but  see  the  remarks  in  Section  PP  DATA. 


RUN 


end 


This  card  instructs  the  program  to  stop  reading  data  and 
start  the  appropriate  computations  for  the  case.  When  the 
case  is  finished,  the  program  returns  to  reading  the  data 
deck.  With  some  exceptions  specifically  noted  elsewhere, 
the  program  does  not  alter  input  values.  Hence,  input  for 
the  next  case  need  only  reflect  changes  to  the  case  just 
run. 


This  card  causes  the  program  to  terminate.  It  is  the  last 
card  of  the  data  deck.  Note  that  the  pteceding  card  should 
be  RUN. 


The  multi-case  capability  can  sometimes  be  utilized  to  effect  sub- 
stantial savings  in  computer  time.  Specifically)  only  those  elements  of 
the  dispersion  tables  which  will  differ  from  Lhe  previous  Ccse  arc  recom- 
puted. The  program  determines  which  elements  must  be  recomputed  by  comparing 
the  values  of  certain  variables  just  before  and  after  an  input  sequence. 

Any  detectable  change  in  the  body  depth,  for  instance,  will  cause  up  to 
four  of  the  dispersion  tables  to  be  recomputed.  A good  general  rule  for 
multi-case  runs  is  thus:  input  only  those  values  which  you  honestly  want 

changed . 
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4.1  Data  Library  Description 

TAPEl  is  the  data  library  file.  It  consists  of  a collection  of 
data  sets,  each  of  which  is  preceded  by  an  Identification  card.  When 
the  input  processor  control  card  LIB  is  encountered  in  the  data  d'dc, 
the  program  locates  the  corresponding  identification  card  on  the  data 
library  file  and  reads  the  data  set  which  follows  it. 

The  format  of  the  identification  cards  is  shown  in  Figure  5. 

Note  that  both  the  type  "t"  and  Identifier  "id"  are  matched  with  the 

LIB  card. 


Identification 

Card 

Description 

*t,id 

The  "*"  is  in  card  column  1.  "t" 

is  a one  character  data  type 
defined  in  Figure  3.  "id"  is  a 
10  character  identifier  matched 
character-for-character  with  the 

LIB  card. 

*END 

Last  card  of  the  data  library. 
Starts  in  card  column  1. 

Figure  5. 


Data  library  identification  card  format 
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Ocean  Data 


This  section  describes  the  variables  which  may  be  input  to  the  name- 
list  set  ()CEAN.  Note  that  all  depths  are  positive.  Units  are  meters, 
seconds,  and  radians. 

1.  Ocean  depth 

OCNDEP  depth  of  the  ocean 


2.  Thermocline  description 


NZT  number  of  points  in  the  thermocline  table,  TDEP  and 

SQBV  (NZT  £ 400) 

TDEP(i)  list  of  thermocline  depths  (at  which  N2  is  specified). 

TDEP(l)  = top  of  the  thermocline  and  is  always  input. 
If  DTDEP  = TDEPMX  = 0,  then  TDEP(i),  i = 2,..., NZT 
must  also  be  input;  otherwise,  the  program  fills  in 
these  entries. 

DTDEP  If  non-zero,  TDEP (i)  = TDEP(l)  + (i  - 1)  *DTD EP , 

i = 2,..., NZT.  Otherwise,  it  is  ignored. 

TDEPMX  If  DTDEP  = 0 / TDEPMX,  A = (TDEPMX  - TDEP(l) ) / (NZT- 1) 

and  TDEP(i)  = TDEP(l)  + (i- 1 ) * A,  i = 2,...,NZT. 
Otherwise,  it  is  ignored. 

NFLAG  =1  : special  option  allows  N = Brunt-Vaisala  frequency 

input  to  SQBV 

=0  : nominal  option  is  N^  input  to  SQBV 
SQBV (i)  N2  at  depth  TDEP(i) 


3.  Dispersion  table  description 

M0DES  . Number  of  modes  in  the  dispersion  tables  (M0DES  ^ 80) 

NK  number  of  entries  in  the  wave  number  list  TABK  (length 

of  dispersion  tables)  (NK  ^ 100) 

TABK(i)  list  of  wave  numbers  at  which  dispersion  relation  is 

computed.  TABK(l)  must  be  0.  If  DKRAT  = 0,  TABK (i ) , 
i = 2,...,NK  must  also  be  input;  otherwise,  the  program 
fills  in  these  entries. 
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DKRAT  If  non-zero,  it  is  the  ratio  of  the  last  increment  in 

K to  the  first  increment,  i.e.,  DKRAT  = (TABK(NK)  - 
TABK(NK-l))/ (TABK(2)  - TABK(l)) 

Using  TABK(l) , DKRAT  and  RKMAX,  the  program  constructs 
TABK(i),  i = 2,...,NK  such  that 

(TABK(i+l)  - TABK ( i ) ) / (TABK ( i ) - TAEK(i-l))  = constant. 

If  DKRAT  = 0,  it  is  ignored. 

RKMAX  If  DKRAT  # 0,  RKMAX  is  the  largest  value  of  K in  the 

wave  number  list.  Otherwise,  it  is  ignored. 

4.  Processed  ocean  data 

The  variables  in  Sections  1,  2 and  3 above  are  sufficient  to  deter- 
mine the  results  of  the  most  time  consuming  part  (eigenvalue  determination) 
of  generating  the  dispersion  tables.  Provision  has  been  made  to  save  these 
results  on  peripheral  storage  so  they  can  be  retrieved  at  a later  date  with 
a resulting  savings  in  computer  time. 

Any  change  to  a variable  in  Sections  1,  2 and  3 results  in  a "new 
ocean"  which  causes  the  program  to  compute  the  entire  set  of  dispersion 
tables  and  write  the  "processed  ocean  data"  onto  file  TAPE2 . At  the  end 
of  the  run,  this  file  can  be  saved.  Only  data  from  the  last  new  ocean  of 
the  run  will  be  on  the  file. 

If  the  first  case  of  a subsequent  run  requires  the  same  ocean,  the 
processed  ocean  data  can  be  retrieved  and  made  available  to  the  program 
on  file  TAPE2.  To  use  that  data,  set  LIBSEA  = 1 and  make  no  entry  to  the 
variables  in  Sections  1,  2,  3. 

The  setting  LIBSEA  = 1 is  valid  only  for  the  first  case,  since  the 
program  internally  generates  a more  complete  set  of  information  for  subse- 
quent cases.  Indeed,  the  program  forces  LIBSEA  = 0 after  the  first  case. 

If  LIBSEA  wereused  for  the  first  case  and  a new  ocean  is  desired  in  a sub- 
sequent case,  the  new  ocean  must  be  completely  defined  by  input.  Input 
variables  are  not  necessarily  saved  as  processed  ocean  data.  Note  that 
the  new  ocean  data  will  be  written  over  the  original. 

LIBSEA  = 0 : ocean  defined  by  input 

= 1 : use  processed  ocean  data  from  TAPE2 
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Skip  dispersion  lclation 


The  capability  exists  to  skip  over 
the  dispersion  tables.  Ordinarily  this 
desired  to  use  the  print/plot  module  to 
earlier. 


the  program  module  which  generates 
would  only  be  done  when  it  is 
display  data  which  were  generated 


NODISP 


- 0 : program  determines  dispersion  table  requirements 
= 1 : si  ip  dispersion  table  generation 


6.  Display 

i 

IPRDT  = 0 : option  off 

= 1 : the  dispersion  tables  are  printed.  Tnis  is  a direct 
print  - the  data  are  not  sent  to  the  print/plot 
module.  The  printing  is  done  from  the  grid  module 
and  only  modes  M0DE1  through  M$DEN  are  printed  (see 
Section  on  GRID  for  definitions  of  M0DE1  and  M(5DEN) . 


IPPDT(i)  = 0 : option  off 

= 1 : dispersion  table  i is  sent  to  the  print/plot  pro- 
cessor, where  table  i is  defined  in  Figure  6. 
These  data  are  generated  in  the  grid  module  and 
include  modes  M0DE1  through  M$DEN. 


IPPVEC  = 0 : option  off 

= i : the  eigenvector  ^ for  mode  i is  sent  to  the  print/ 
plot  processor.  The  PP  id  is  EVEC.  The  data  are 
generated  in  the  dispersion  table  module. 


IPREDG  = 0 ; option  off 

= 1 : the  wave  family  edge  tables  are  printed.  This  is 

a direct  print- the  data  are  not  sent  to  the  print/ 
plot  module.  The  printing  is  done  from  the  stationary 
phase  module  and  only  modes  MfitoEl  through  M0DEN  are 
printed . 
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Table 


PP  id 


dX/dK 

DL/DK 

i[i  (obs  depth)  [eigenfunction] 

W(0BS) 

dili/dz  (obs  depth) 

DW/DZ (0BS) 

dilt/dz  (body  depth) 

DW/DZ(B0D) 

1^  [wake  integral] 

TWAKE 

ill  (super  bottom)  - \|j  (super  top) 

TSUPR 

x [“i/c2] 

LAMBDA 

2 2 
a X/ dK 

D2L/DK2 

-y/x 

-Y/X 

4.3 


Source  Data 


This  section  describes  the  variables  which  may  be  input  to  the  name- 
list  set  SOURCE.  Units  are  meters  and  seconds.  The  net  disturbance  is 
the  superposition  of  all  selected  sources. 


IBODY 

= 0 ; 

option  off 

= 1 : 

Rankine  body  is  simulated.  Required  inputs  are 
B0DD  EP , B0Tj S PD  , B (fob  lA , B(fo L EN 

= 2 : 

dipole  body  is  simulated.  Required  inputs  are 
B0DD  EP , BCSDS  PD , B0DD IA 

ISUPR 

= 0 ; 

option  off 

= 1 : 

a superstructure  with  ellipsoidal  cross  section 
is  simulated.  Required  inputs  are  B0DDEP,K0DSPD, 
SUPT0P , SUPB0T , SUPMID , SUPD IA , SUPLEN 

= 2 : 

a superstructure  with  circular  cross  section  is 
simulated.  Required  inputs  are  B0DDEP,B0DSPD, 
SUPT0P, SUPB0T, SUPMID , SUPD IA 

IWAKE 

= 0 : 

option  off 

= 1 : 

a wake  xs  simulated.  Required  inputs  are 
B0DDEP, B0DSPD , CWAKR . CWAKX , R ES  LVS , CWAKM, B0DDIA 

IPB0DY 

= 0 : 

option  off 

= 1 : 

the  potential  solution  of  a Rankine  body  is 
evaluated.  Required  inputs  are  the  same  as  for 
IB0DY=1;  see  also  XPMAX,YPMAX,  and  ISPHAS  in  the 
section  GRID  DATA. 

IPSUPR 

= 0 : 

the  potential  solution  of  a superstructure  with 
ellipsoidal  cross  section  is  evaluated.  Required 
inputs  are  the  same  as  for  ISUPR=1;  see  also 
XPMAX,  YPMAX  and  ISPHAS  in  the  section  GRID  DATA. 

BCtoDEP 

depth 

i of  the  body  centerline  (input  positive) 

B0DSPD 

body 

speed 

B0DDIA 

body 

diameter 

B0DLEN 

body 

length 
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SUPT0P 


distance  from  body  centerline  to  top  of  superstructure 
line  source  (positive  up) 


SUPB0T 

SUPVID 

SUPDIA 

SUPLEN 

CWAKR 


CWAKX 

CWAKM 

RESLVS 


distance  from  body  centerline  to  bottom  of  superstructure 
line  source  (positive  up) 

x coordinate  of  center  of  superstructure  (x=0  at  body  center) 

maximum  transverse  dimension  of  superstructure 
superstructure  length 

sizing  coefficient  for  wake  radius.  a = C — 

w r 2 

where  a = wake  radius,  C = CWAKR,  D = body  diameter, 

” 2 tt  U ^ 

F = Froude  number  = with  U = body  speed, 

N = local  average  Brunt- Vaisala  frequency 

coefficient  for  computing  start  of  wake  collapse, 
x = C DF  where  x is  x coordinate  of  start  of  wake 

W X w 

collapse,  Cx  = CWAKX  and  D and  F are  as  above, 
wake  mixing  fraction  = e 

The  integral  in  the  wake  source  term  is  performed 
numerically  via  trapezoidal  integration.  The  step 
size  is  varied  to  hit  each  thermocline  point  within 
the  wake  while  ensuring  that  the  increment  in  the 
argument  of  the  sine  function  never  exceeds  rr/RESLVS. 
RESLVS=5  may  be  used  as  a rule  of  thumb. 


4.4  Grid  Data 


This  section  describes  the  variables  which  may  be  input  to  the 
namelist  set  GRID.  Units  are  meters  and  seconds. 

1.  Grid  Variable 

IVAR  The  value  of  IVAR  selects  the  variable  (or  signal)  to 

be  computed  at  each  grid  point.  The  options  are  given 
in  Figure  7 . 


IVAR 

Variable 

Name 

1 

/ 

u 

X- VELOCITY  (U) 

2 

V 

Y-VELOCITY  (V) 

3 

6 

X 

X-DISPLACE  (DELTA-X) 

4 

6 

y 

Y-DISPLACE  (DELTA-Y) 

5 

z 

Z-DISPLACE  (DELTA-Z) 

6 

e 

X 

X-STRAIN  (EPSIL0N-X) 

7 

e 

y 

Y-STRAIN  (EPS IL0N-Y) 

8 

V 

Txy 

SHEAR  STRN  (GAMMAXY) 

9 

a 

DILATATION  (SIGMA) 

10 

w 

Z-VELOCITY  (W) 

Figure  7.  Grid  Variable  Selection 

2 . Mode  Range 

The  output  signal  will  be  computed  as  the  superposition  of  modes 
M0DE1  through  M0DEN  inclusive.  Note  that  1 £ M0DE1  ^ M0DEN  £ M$DES  where 
M0DES  is  the  number  of  modes  in  the  dispersion  tables  (see  the  section 
OCE£N  DATA).  The  range  of  modes  in  the  grid  computation  MODEN-MODEl  + 1 £ 40. 

M$DEl  first  mode  in  grid  computation. 

M0DEN  last  mode  in  grid  computation. 
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3.  Near/Far  Field  Selection 

In  the  near  field  option,  a fast  Courier  transform  (FFT)  technique 
is  used;  a potential  solution  is  also  available.  In  the  far  field  option, 
a stationary  phar.e  technique  is  used. 

Typically,  in  the  far  field,  the  FFT  will  exhibit  aliasing  problems 
while  the  potential  solution  becomes  negligible.  In  the  near  field,  the 
stationary  phase  approximation  becomes  inaccurate. 

ISPHAS  = 0 : (near  field)  use  FFT  and/or  potential  solution. 

= 1 : (far  field)  use  stationary  phase.  Note:  while 

the  y coordinates  of  the  grid  are  input  positive, 
the  stationary  phase  module  actually  uses  negative 
y values.  In  the  output  displays,  this  is  reflected 
by  labeling  the  y coordinate  as  "-y".  This  quirk 
cannot  be  circumvented  by  input. 

4.  Grid  Definition 

The  signal  values  are  computed  and  displayed  at  the  points  of  a two 
dimensional  grid.  The  coordinates  of  the  grid  points  are  (X^  Y^,  Zk) , 
i-1, . . . ,NX;  j=l, . . . ,NY ; k-l,...,N0BS.  Exactly  one  of  the  NX,  NY,  N0BS 
must  equal  1.  If  the  FFT  option  is  used,  NY  must  be  greater  than  1. 


If  N0BS=1,  an  X-Y  grid  Is  generated;  in  the  language  of  che  print/ 
plot  processor,  the  signal  is  generated  as  a function  of  Y with  X as  the 
parameter.  If  NX=1,  a Z-Y  grid  is  generated;  in  the  language  of  the  print/ 
plot  processor,  the  signal  is  generated  as  a function  of  Y with  Z as  the 
parameter.  If  NY-1,  a Z-X  grid  is  generated;  the  signal  is  a function  of 
X with  Z as  the  parameter. 

nMrs  number  of  observation  depths  (z  grid  points).  If  greater 

than  1,  the  observation  depth  0BSDEP  is  successively  set 
to  the  values  in  the  table  of  observation  depths  TABOBS  (i) , 
i=l, . . . ,N0BS . The  limit  is  N0BS  ^ 100.  If  N0BS  - 1,  an 
X-Y  grid  is  assumed,  the  observation  depth  is  input  to 
OBSDEP  and  TAB0BS  is  igno*-  d. 
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OBSDE? 


observation  depth.  Depth  is  positive  and  0 ^ 0BSDEP  £ 
0CNDEP. 


TABtf)BS(i)  (used  only  if  N0BF  > 1)  list  of  observation  depths.  Depths 
are  positive  and  0 ^ TAB^BS(i)  ^ 0CNDEP,  i=l , . . . , N0BS . 

The  first  depth  is  input  to  TAB$BS(1).  If  D(6BS  = OBSMAX  = 0, 
then  TAB0BS  (i ) , i=2 , . . . , N(6fiS  must  also  be  input;  otherwise 
the  program  fills  in  these  entries. 

D0BS  If  non-zero,  TABLES  (i)  = TAB0BS (1)  + (i-1)  * D0BS, 

i=2 , . . . , N0BS . Otherwise,  it  is  ignored. 


(0BSMAX  If  D(SBS  = 0 / 0BSMAX,  A = (0BSMAX  - 1AB0BS  (1)  ) / (N0BS- 1) 

and  TABLES  (i)  = TAB0BS(1)  + (i-1)  * A,  i=2 , . . . , N0BS . 
Otherwise  it  is  ignored. 


NX  number  of  downstream  stations  (X.)  in  the  grid.  Fer  a 

Z-Y  grid,  NX=1  and  XMIN  is  the  desired  value  < f X.  Otherwise  NX, 
XMIN  and  DX  define  the  X coordinates  of  the  grid.  If  NX=0,  the 
grid  computation  is  skipped.  (NX  ^ 800). 


XMIN 

DX 

NY 


YMIN 

DY 


first  value  of  X in  the  g-'id. 


grid  increment  in  the  X direction.  Note  X^XMIN  + (i-l)*DX. 


number  of  grid  points  along  the  cross  track  ,(Y)  axis.  If 
the  FFT  option  is  used,  NY  must  be  a power  of  2 and 
1 < NY  ^ 256.  If  only  the  potential  solution  is  used, 

1 5 NY  S 2000.  If  the  stationary  phase  option  is  used, 

1 5 NY  5 800. 

first  value  of  Y in  the  grid.  This  applies  to  stationary 
phase  only.  For  near  field,  it  is  assumed  vMIN=0. 


grid  increment  in  the  Y direction.  Note  Y^  = YMIN  + (i-l)*DY . 


5.  Potential  Solution  Grid  Limits 

The  grid  defined  above  applies  to  the  wave-like  solution.  The  poten- 
tial solution  is  evaluated  at  the  same  grid  points  subject  to  the  restrictions 
imposed  by  XPMAX  and  YPMAX. 

XPMAX  The  potential  solution  will  be  evaluated  only  at  grid 

points  with  coordinate  £ XPMAX. 

YPMAX  The  potential  solution  will  be  evaluated  only  at  grid 

points  with  coordinate  Y^  ^ YPMAX. 
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IPPPSD 


option  off 

(FFT  option  only)  power  spectral  density  (PSD) 
data  are  sent  to  the  pp  processor.  Note  that 
the  Fourier  transform  (from  y to  n)  of  the  signal 
may  be  written 

F(T|,x)  = Re  (f(Tl)ei?X)  or  F(Tl,x)  = i Im(f  (T»ei?X) ; 

the  PSD  is  computed  as  |f(T])|^.  A PSD  display  is 
generated  for  each  source  per  Figure  8. 


b.  Skip  Grid 

The  capability  exists  to  skip  over  the  program  module  which  performs 
the  grid  computations.  Ordinarily,  this  would  only  be  done  when  it  was 
desired  to  use  the  print/plot  module  to  display  data  which  were  generated 
earlier. 

N(6CRID  = 0 : program  determines  grid  requirements 

= 1 : skip  grid  computation 

7 . Display 

Note  that  the  signal  values  at  the  grid  points  are  always  sent  to 
the  print/plot  (pp)  processor.  The  pp  id  for  that  display  is  CUTS. 


Source 

PP  id 

body 

BPSD 

wake 

WPSD 

super- 

structure 

SPSD 

Figure  8.  PSD  Displays 


i 
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4.5  PP  Data 


This  section  describes  the  operation  and  input  to  the  print/plot  (PP) 
processor.  The  PP  processor  is  capable  of  displaying  a function  of  two 
variables  f(p,v)  where  p is  treated  as  a parameter  and  v is  used  as  the 
independent  variable.  "Display"  means  print  and/or  plot. 


When  f(p,v)  is  printed,  the  value  of  f is  listed  for  each  value  of  v; 
such  a list  is  generated  for  each  value  of  p.  It  is  also  possible  to  pro- 
duce a "summary  print"  which  lists,  for  each  value  of  p:  the  extrema  of 

f,  the  values  of  v af  which  th°  extrema  are  attained, 


f (PjV) 


dv  and 


(P»v) 


dv. 


There  are  two  plot  formats  available.  For  a "multi-trace  plot",  the 
ordinate  is  f,  the  abscissa  is  v and  one  trace  is  drawn  for  each  para- 
meter value  (see  Figure  9).  For  a "raster  plot"  the  ordinate  is  v,  the 
abscissa  is  p and  f is  plotted  as  a displacement  along  an  axis  parallel 
to  the  abscissa  (see  Figure  10).  No  display  will  be  generated  for  any 
value  of  p which  has  less  than  two  values  of  v. 


A display  data  set  (DDS)  consists  of  the  values  of  f,  p and  v along 
with  a preset  format.  During  the  computational  phase  of  a case,  DDS's  are 
written  on  files  TAPE9  and  TAPElO.  The  various  DDS's  which  may  be  written 
on  these  files  are  determined  by  input  options  described  earlier  and  sum- 
marized in  the  first  two  columns  of  Figure  12.  Each  DDS  (that  is,  each 
function  which  may  be  displayed)  is  assigned  a 1 to  10  character  identifier 
called  the  "id". 

The  standard  option  is  to  display  all  DDS's  on  the  files  based  on  the 
preset  format  assigned  to  each  of  them.  However,  it  may  be  desirable  to 
reformat  some  of  the  displays  and  eliminate  others,  while  relying  on  the 
preset  formats  for  the  remaining  DDS's.  The  variables  in  the  Pp  namelist 
set  (PP  is  the  namelist  name)  allow  the  preset  format  of  a DDS  to  be  over- 
ridden (this  includes  a skip  or  no-display  capability).  With  the  desired 
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BODY } 
.01268. 


reformatting  of  a display  reduced  to  namelist  form,  the  problem  is  to 
identify  which  DDS  on  TAPE9  and  TAPElO  is  to  be  reformatted.  The  problem 
is  compounded  since,  in  a multi-case  run,  more  than  one  DDS  may  have  the 
same  id. 

The  problem  is  solved  by  including  in  the  PP  namelist  set  two  variables 
which  act  as  locators.  These  locators  select  the  DDS  which  is  to  be  reformatted. 
The  namelist  set  is  thus  composed  of  two  parts: 

1.  the  tw<  locators 

2.  the  remaining  namelist  variables,  which  constitute  ..he  print/plot 
format  block  (PPFB) . 

The  two  locators  are  named  IDPP  and  I0CUR.  The  id  of  che  desired  DDS  is 
entered  as  Hollerith  data  into  IDPP.  The  locator  I0CUR  is  used  to  differ- 
entiate between  DDS's  with  the  same  identifier.  Thus  I0CUR=2  means  the 
PPFB  should  be  applied  to  the  second  DDS  with  the  given  id. 

A PP  namelist  -jet  must  be  input  for  each  DDS  which  needs  attention.  If 
the  locators  (both  of  them)  in  one  namelist  set  do  not  match  the  locators 
in  any  previous  set,  then  a new  PPFB  is  generated;  that  is,  the  PPFB 
is  entered  into  a virgin  array.  If,  on  the  other  hand,  both  locators  match 
with  a previous  namelist  set,  the  PPFB  is  read  in  on  top  of  (overlays)  the 
matched  PPFB. 
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| Variable 

Preset  Value 

I PRINT 

2 

TPL0T 

1 

IPLTYP 

See  Figure  12 

ISVM 

0 

TITLE 

See  Figure  12 

FNAME 

See  Figure  12 

FMIN 

min  [ f (p  jV) ] 

FMAX 

max  [f(p,v)] 

FLEN 

8. 

FT0DP 

± 1.  (minus  if  p = depth) 

VNAME 

See  Figure  12 

VMIN 

min  [v] 

VMAX 

max  [v] 

VLEN 

10.  (multi-trace) , 8.  (raster) 

PNAME 

See  Figure  12 

PMIN 

min  [p] 

PMAX 

max  [pl 

PLEN 

10. 

I ED  IT 

0 

i’0PP 

0 

Figure  11.  Presets  for  PPFB  Variables 


The  variables  in  the  PP  namelist  set  are  defined  below. 

IDPP  1 to  10  character  Hollerith  identifier  of  the  DDS  to  which 

this  PPFB  will  apply.  If  not  input,  the  PPFB  will  be  applied 
to  all  displays  except  those  specifically  named  in  another 
PP  namelist.  Input  of  all  blanks  is  equivalent  to  no  input. 

ItJCUR  If  not  input,  the  PPFB  will  apply  to  all  DDS's  with  the  given 

IDPP  except  those  whi<"h  have  I0CUR  >0.  If  I0CUR  = i > 0, 
this  PPFB  will  apply  only  to  the  ic^  DDS  which  has  the  given 
IDPP.  I0CUR  = 0 is  equivalent  to  no  input.  I0CUR  < 0 is 
illegal.  If  IDPP  was  not  input,  I0CUR  must  not  be  input 
either. 


I PRINT 

= 0 : no  print 
= 1 : print  f(p,v) 

= 2 : print  data  summary  (extrema,  etc.) 
= 3 : print  1+2 

IPL0T 

=0  : no  plot 
= 1 : plot  f(p,v) 

IPLTYP 

= 0 : produce  raster  plot  (if  plotting) 

= 1 : produce  multi-trace  plot  (if  plotting) 

ISYM 

applies  only  when  generating  a multi-trace  plot 
= 0 : traces  will  not  be  labeled 

= 1 ; a unique  symbol  will  be  drawn  at  the  first  and  last 
point  of  each  trace  and  keyed  with  the  corresponding 
parameter  value. 

TITLE 

a 20  character  (2  word)  title  which  will  be  included  in  the 
display  (Hollerith) 

FNAME 

function  name.  This  is  a 20  character  (2  word)  Hollerith 
descriptor  used  to  label  the  function  in  the  display.  An  input 
to  FNAME  does  not  change  the  function,  only  its  label. 

FMIN 

minimum  value  of  f.  This  is  used  only  for  plot  scaling;  it  is 
not  used  to  limit  the  value  of  f.  For  a multi-trace  plot,  it 
is  the  value  of  f at  the  origin.  For  a raster  plot,  f = 0 
at  the  origin. 

FMAX 

maximum  value  of  f.  This  is  used  only  for  plot;  scaling;  it  is 
not  used  to  limit  the  value  of  f.  For  a multi-trace  plot,  it 
is  the  value  of  f at  the  end  of  the  f axis.  For  a raster  plot 
| f 1 max  = max  ( |FMIN  |,|FMAX  1)  is  the  value  of  f at  the  end  of 
the  f axis . 
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FLEN 

FT0DP 


VNAME 

VMIN 

VMAX 

VLEN 

PNaME 

PMIN 

PMAX 

PLEN 

IEDIT 


length  in  inches  of  the  f axis.  For  a multi- trace  plot,  FLEN 
is  always  used.  For  a raster  plot,  it  is  used  directly  only 
if  FT0DP  = 0;  otherwise  the  program  uses  FT0DP  to  compute 
FLEN. 

(used  only  for  raster  plotc  to  determine  FLEN)  if  non-zero,  it 
is  the  ratio  of  the  length  or  the  f axis  to  the  average  distance 
(in  inches)  between  traces.  Specifically, 

FLEN  = FrtDP  * (|^??)  * (^AxTSff.) 

where  N is  the  number  of  parameter  values  in  the  DDS  and  Ap 

is  the  parameter  range  (p  - p . ) in  the  DDS.  If  FT0DP  = 0, 

. ° 'max  'min' 

it  is  ignored. 

a 10  character  Hollerith  descriptor  used  to  label  the  indepen- 
dent variable  in  the  display.  An  input  to  VNAME  does  not 
change  the  variable,  only  its  label. 

minimum  value  of  v.  Data  associated  with  values  of  v < VMIN 
are  discarded.  VMIN  is  also  used  as  the  origin  of  the  v 
axis  for  plotting. 

maximum  value  of  v.  Data  associated  with  values  of  v > VMAX 
are  discarded.  VMAX  is  also  used  as  the  value  of  v at  the  end 
of  the  v axis. 

length  in  inches  of  the  v axis. 

a 10  character  Hollerith  descriptor  used  to  label  the  para- 
meter in  the  display.  An  input  to  PNAME  does  not  change  the 
parameter  only  its  label. 

minimum  value  of  p.  Data  associated  with  values  of  p < PMIN 
are  discarded.  For  a raster  plot,  PMIN  is  also  used  as  the 
origin  of  the  p axis. 

maximum  value  of  p.  Data  associated  with  values  of  p > PMAX 
are  discarded.  For  a raster  plot,  PMAX  is  also  used  as  the 
value  of  p at  the  end  of  the  p axis. 

length  in  inches  of  the  p axis  for  a raster  plot  (multi-trace 
plots  do  not  have  a p axis). 

Ordinarily,  all  DDS 1 s on  TAPE9  and  TAPE10  are  displayed,  except 
those  for  which  a PPFB  was  input  with  IPRINT  = IPL0T  = 0. 

However,  if  IEDIT  = 1 in  any  PPFB,  then  the  only  DDS's  which  will  be 
displayed  are  those  for  which  a PP^B  was  input.  Replacing  the 
IEDIT  = 1 with  IEDIT  = C restores  the  nominal  option. 


N0PP 


■ I 


Ordinarily,  the  DDS's  generated  during  the  computational 
phase  of  a case  are  displayed  at  the  end  of  that  case. 

The  files  TAPE9  and  TAPElO  are  then  rewound  and  display 
data  generated  in  the  next  case  overwrites  the  old  data. 
However,  if  N0PP  = 1 in  any  PPFB,  no  displays  are  generated 
and  the  positions  of  TAPE9  and  TAPElO  are  undisturbed. 

During  a multi-case  run,  this  permits  all  the  display  data 
to  be  accumulated  on  these  files.  Presumably,  in  the  last 
case  of  the  run,  the  N0PP  = 1 will  be  replaced  with  N0PP  = 0 
to  display  the  accumulated  data.  The  advantage  in  accumu- 
lating data  is  that  TAPE9  and  TAPElO  can  be  saved  and  a 
subsequent  run  made  to  reformat  the  displays.  The  disad- 
vantage is  that  TAPE9  can  become  quite  large. 


u 


5. 


SAMPLE  CALCULATIONS 


This  section  presents  a series  of  three  computer  runs  designed  to  illus- 
trate the  operation  of  the  SEEK  program.  The  data  are  fictitious  but  not  un- 
reasonable. The  parameters  were  chosen  in  a cavalier  manner  in  order  to  point 
out  common  sources  of  error. 

In  the  first  run,  the  fast  Fourier  transform  technique  is  used  to  com- 
pute the  disturbance  due  to  a Rankine  body  with  a wake.  Both  the  y-strain 

(e  ) and  y-velocity  (v)  are  displayed.  The  ocean,  body  and  wake  descriptions 
v y' 

are  on  the  data  library  file,  TAPEl.  Other  input  data  are  introduced  from 
the  INPUT  file.  Processed  ocean  data  on  TAPE2  are  saved  at  the  end  of  the 
run.  PP  data  (TAPE 9,  TAPElO)  for  the  last  case  are  also  saved  at  the  end  of 
the  run. 

For  the  second  run,  files  TAPE 9 and  TAPElO  are  restored  and  the  pro- 
gram is  used  to  reformat  the  displays  associated  with  the  last  case  of  the 
first  run. 

The  third  run  uses  the  processed  ocean  data  generated  in  the  i^rst  run 
to  extend  the  grid  beyond  the  point  at  which  aliasing  occurs  in  -h_  FFT 
solution. 

5.1  Run  1 

The  next  two  pages  are  a listing  of  the  input  data  library  file  (TAPEl) . 
Note  that  three  data  sets  are  on  the  file.  The  first  data  set  (introduced 
by  *S , B 1 ) defines  a Rankine  body.  The  second  (introduced  by  *S,Wl)  defines 
a wake  model.  The  third  data  set  (introduced  by  *0,S2)  defines  the  ocean 
and  the  dispersion  tables. 

The  P which  precedes  each  namelist  name  (e.g.,  P$S0URCE)  activates  a 
special  TRW  modification  to  NAMELIST  which  causes  the  card  images  to  be 
printed  as  they  are  read. 

It  should  also  be  noted  that  TRW's  system  presets  memory  to  zero  before 
execution.  For  installations  for  which  this  is  not  true,  it  is  recommended 
that  the  input  data  library  contain  data  sets  which  set  all  input  variables 
to  zero.  These  data  sets  can  be  called  in  at  the  start  of  a run  by  LIB 
cards  to  effect  the  preset. 

At  the  end  of  the  run,  TAPE2  (processed  ocean  data)  was  saved,  along 
with  TAPE9  and  TAPElO  (display  data  for  the  second  case  of  the  run). 
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The  next  page  is  a listing  of  the  data  deck  (file  INPUT)  used  for  the 
first  run. 

Note  that  the  S0UPCE  data  are  the  result  of  three  different  reads, 
each  data  set  being  superimposed  on  the  previous  data. 

} 

The  GRID  data  specify  an  x-y  grid  (N0BS=1)  at  the  surface  ({)BSDEP=0) 
The  grid  variable  to  be  computed  is  y-strain,  (IVAR=7).  Since  ISPHAS=0, 

the  FFT  technique  will  be  used.  IPPPSD=1  causes  the  power  spectra  to  be 
displayed . 

The  first  PP  data  set  calls  for  a special  format  for  the  grid  display 
(IDPP=4HCUTS) . The  x-axis  is  to  start  at  zero  (PMIN=0)  rather  than  the 
default  value  of  400  (since  XMIN=400).  The  lengths  of  the  y and  x axes 
have  been  decreased  so  the  plot  will  fit  on  8^  x 11  paper.  The  function 
scaling  has  been  increased  by  a factor  of  5 (FT0DP=5)  to  make  the  distur- 
ance  pattern  more  apparent.  Since  the  second  PP  data  set  has  no  entry  to 
IDPP,  it  applies  to  all  displays  except  CUTS.  The  only  other  displays  in 
this  instance  are  the  power  spectra.  The  lengths  of  the  axes  are  reduced 
to  fit  on  8^  x 11  paper. 

The  RUN  card  causes  the  first  case  to  be  executed.  The  second  case 
is  the  same  as  the  first  except  y-velocity,  v (IVAR=2)  will  be  computed  and 
the  grid  increment  in  y is  different.  Also,  the  plot  of  the  wake  PSD  will 
have  a label  on  each  trace. 
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5.2  Run  2 

The  second  run  is  a simple  illustration  of  reformatting  a display. 

TAPE9  and  TAPElO,  which  were  saved  at  the  end  of  run  1 are  now  restored. 

These  files  contain  all  the  print/plot  data  for  the  second  case  of  run  1. 

It  i3  desired  to  re-plot  the  y-veloc.ity  display,  cutting  it  off  at  X = 12500, 
but  otherwise  keeping  the  same  scaling. 

The  data  deck  is  listed  below. 

INP,0 

PSOCEAN  N0DISP=1$ 

INP,G 

PSGRID  NOGR I D=  1 S 

I NP»  P 

PtPP  IDPP=4HCUTS,  I EDIT  = 1»  PMIN  = 0»  PM4X=12500,  ?LEN=5» 
VLEN*6»  FTODP*^.,  FLEN= . 4»  IPRINT=0$ 

RUN 

END 

The  entries  N0DIS?  = 1 and  N0GRID  = 1 cause  the  program  to  bypass 
the  dispersion  table  and  grid  modules  and  directly  enter  the  print/plot 
processor. 

The  entry  IDPP  = 4HCUTS  indicates  that  this  PP  data  set  applies  to 
the  grid  display  (if  there  were  more  than  one  grid  display,  I0CUR  could 
be  used  to  specify  which  one).  IEDIT  = 1 causes  the  program  to  process 
only  those  displays  called  out  in  a PP  data  set.  Since  CUTS  is  the  only 
display  mentioned  by  input,  this  eliminates  the  BPSD  and  WPSD  displays. 

This  could  also  have  been  done  by  entering  data  sets  for  BPSD  and  WPSD 
with  IPRINT  = 0 and  IPL0T  = 0. 

Tie  variables  PMIN  and  PMAX  specify  the  range  of  the  parameter  X to 
be  displayed.  The  lengths  of  the  X and  Y axes  are  set  to  5 and  6 inches, 
respectively.  Setting  FT0DP  = 0 causes  the  program  to  bypass  the  auto- 
matic function  scaling  and  use  FLEN  as  the  length  of  the  function  axis 
(.4  was  arrived  at  by  measuring  the  length  of  the  function  axis  in  the 
display  from  run  1).  IPRINT  = 0 turns  off  all  printing  for  this  display. 
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5 . 3 Run  3 


Examination  of  the  grid  plot  for  y-velocity  in  run  1 indicates  that 
aliasing  becomes  obvious  at  about  10000  to  15000  meters  downtrack.  In 
run  2,  the  grid  was  cut  off  at  X = 12400  meters.  It  is  now  desired  to 
extend  the  grid  from  12600  (cross  cuts  are  computed  at  200  meter  intervals) 
back  to  14000  meters  using  the  stationary  phase  method,  and  plot  it  with 
the  same  scaling  as  before. 

The  data  deck  is  listed  below. 


INPtO 

P SCC E AN  LlU$rA=l,  iPRE0G=li 

L I B t S « 1 
LIBtStWl 
I NP » S 

PSSOUkCt  BGC0EP=45,  eODSPIJ=2$ 

INPiG 

PSGNID  ORS  DEP=0 , N0BS  = 1,  0X=200,  XMI\|  = l2oCC,  NX=o,  3Y  = 13,  NY=255, 
YMIN=13»  MCCE1=1,  MCDEN=9,  lVAR=2f  1SPHAS=1S 

I NP » P 

PSPP  IUPP=4HCUrS,  PM  IN  = 10000»  PMAX  = 15000,  PLEN  = ,u,  VMIN  = 0,  VLbN=6 
FMAX=  1 .255bj5E-3,  FM IN  = - 1 . 25 26 55E- 3t  FT3DP  = 0,  FLEN  = -.4S 
RUN 
EN0 


The  processed  ocean  data  on  TAPE2  which  was  saved  at  the  end  of 
run  1 is  restored  for  this  run.  The  same  input  data  library  (TAPEl) 

which  was  used  in  run  1 is  also  used  here. 

The  entry  LIBSEA=1  causes  the  processed  ocean  data  to  be  read 
from  TAPE2.  IPREDG  causes  the  wave  family  edge  table  to  be  printed. 

The  two  LIB  cards  bring  in  the  same  body  and  wake  models  used  before. 

The  grid  data  are  the  same  as  the  second  case  of  run  1 except  that  sta- 

tionary phase  is  used  (ISPHAS=1)  and  the  range  of  X is  12600  to  14000 
(XMIN=12600,  NX=8,  DX=200) . No  wall  reflections  appear  in  the  solutions 
since  the  lateral  boundary  is  at  y-*co  . 
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The  plot  scaling  is  designed  to  allow  this  plot  to  be  laid  at  the 
end  of  the  run  2 plot  to  form  a single  picture.  PMIN  and  PMAX  are  values 
of  X at  tic  marks  on  the  old  plot  and  which  bracket  the  actual  range  of  X. 
Since  the  tic  marks  are  always  spaced  one  inch  apart,  the  appropriate 
length  of  the  X axis  is  given  by  PLEN=2.  VMIN=0  causes  the  origin  of 
the  Y axis  to  be  zero  instead  of  13,  which  is  where  the  stationary  phase 
grid  starts.  To  force  the  same  scaling  as  before,  FMAX  and  FT1IN  are  set 
to  ± maximum  value  found  in  the  previous  run.  Note  that  the  negative 
value  input  to  FLEN  causes  the  function  axis  to  be  reversed;  thus  nega- 
tive function  values  are  plotted  to  the  right,  positive  to  the  left. 

This  was  done  so  that  the  pattern  would  appear  to  be  a continuation  of  the 
run  2 plot  (remember  that  for  an  FFT  grid  Y^O,  for  a stationary  phase  grid 
Y<  0,  and  v(-Y)=  -v(Y)). 
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This  section  contains  a complete  listing  of  program  SEEK. 


The  subroutines  are  broadly  divided  into  seven  categories. 

1.  Control  and  general  purpose.  Routines  are  ordered 
alphabetically. 

2.  Dispersion  table  generation.  Routines  are  ordered 
alphabetically.  Routine  names  begin  with  DT. 

31  Fourier  transform  solution.  Routine  names  begin  with 
FT.  Ordering  is  alphabetical. 

4.  Input  processor.  The  order  is  alphabetical,  the  prefix 
is  IN. 

5.  Print/plot  processor.  The  order  is  alphabetical,  the 
prefix  is  PP. 

6.  Stationary  phase.  The  order  is  alphabetical,  the  prefix 
is  SP. 

7.  Math.  General  purpose  math  routines  in  no  particular 
order. 

The  program  requires  a field  length  of  about  215000  (octal)  words 
on  a CDC  6400. 


c 

c 


PROGRAM  SFEKIT APE1~1004,  TAPE2,  TAPE3,  TAP  E4 

1,  INPUT=1004,TAPE5=INPUT,  OUTPUT , TAP E 6=0UTP UT 

2,  TAPE7=104,  T APE8= 1004 

3,  TAPE9,  T AP  E 10= 100  4,  TAPE50  = 104) 

FOR  FILE  USACE,  SEE  ROUTINE  1NKUN1 

COMMON  /CONTRL/  ICASE,  IC<F_G(20>,  JDIS?,  JFFT,  JPOT 
It  NODISP,  NOGRID 

EQUIVALENCE  { MODS  E A,  IC<  FL  G{  1 )) , I MODOBS,  ICKFLG  ( 2 ) ) 

1,  (MODBODi ICKFLGI3)  ),  { MOQWAK , ICK FLG { 4 ) ) , { MODSUP  » I 2 KF  LG ( 5 ) ) 


C 

C 

C 


C 

C 

C 

C 

C 

C 

C 

C 


C 

C 


c 

c 


c 

c 

c 


COMMON  /GRID/  OBSDEP,  NOBS, 
It  X,  CX,  XMIN,  NX,  ITHX, 

2,  IVAR,  1PRDT,  IPPDTm, 

3,  ISPHAS 


DOBS,  ObSMAX,  TABJBS(IOO), 


Y,  DY,  YMIN,  NY,  I THY,  MODE  I, 
XPMAX , YPMAX,  IPPPSD,  I PREDG 


I THORS 

MODEN 


10 


20 


TABL  ES 
DT  CON 


IF  NtCESSARY 


INITIALIZE  CASE  NUMBER 
ICASl  = 0 
CALL  VIMERIO  ) 

READ  INPUT  FCR  NEXT  CASE 
CALL  INCON 
’NlTIALIZt  THE  CASE 
CALL  CASE1 
ITHOBS  = 1 

GENERATE  NEW  DISPERSION 
IF  (JDISP  .NE.  0)  CALL 
SKIP  IF  NO  GRID 
IF  (NOGRIC  .NE.  0)  GO  TO  30 
STATIONARY  PHASE  SOLUTION  CONTROL 
IF  {ISPHAS  .NE.  0)  CALL  SPCON 

FOURIER  TRANSFORM  AND  POTENTIAL  SOLUTION  CON  TR UL 

IF  ( JFFT  + J POT  .NE.  0)  CALL  FT  CON 

SKIP  IF  ALL  OBSERVATION  DEPTHS  HAVE  BEEN  DONc 

IF  (ITHOBS  .GE.  NOBS)  GO  TO  30 

NEXT  OBS  DEPTH 

ITHOBS  = ITHCBS  +1 

CBSDFP  = TABOBSI  ITHOBS ) 

RESET  CHECKLIST  FLAGS  INDICATING  0N1.Y  03S  DEPTH  HAS  CHANGED 


MODSEA 
MODBOD 
MODWAK 
MODSJP 
MODOBS 
GO  TO 


0 

0 

0 

0 

1 


20 


PRINT/PLOT  CONTROL 
30  CALL  PPCON 
GO  TO  10 
ENC 

SUBROUTINE  BODY  1 

COFPUTE  BODY  SOURCE  PARAMETERS — STRENGTH  AND  1/2  SEPARATION 

COMMON  /BODY/  I BODY , IP80DY,  BODDEP , B3DDI A , BODLLN  , BODSPD 
1,  RBSEP2,  RBSTR,  RBLIM 

COMMON  / CCNST/  JDK,  JDMODE,  JDTCL,  NULL,  JDCKL,  JDMF  T 

1,  JOCKS  V t JDMSP,  JOEDGE 


TEST  BOOY 
IF  (I  BODY 


MODEL 
.NE.  1 


.AND. 


IPBODY 
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.NE.  1)  GO  TO  50 
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C RANKINE  BODY 

B02  = BCCCIA/2. 

SQBD2  = BD2**2 
BL2  = BODLEN/2. 

SQBL2  = BL2  **2 

C INITIAL  GUESS  FOR  SQUARE  OF  (SOURCE  SEPARA T ION ) /2 

SQ A = 0. 

C ITERATE  FOR  SQ  A 

DO  20  1=1,20 

CLDSQA  = SGA 

SOA  = SQBL2  - BD2  *(  SQBL 2* < SQA  + SQBD2 ) . 25 

20  IF  ( ABS ( SQA-OL  DSQA)/SQBL2  .LE.  l.E-10)  SO  TO  40 
WRITE (6,30)  SGA, OLDSQA 

30  FORMAT  (41H  NO'  CONVERGENCE  ON  BODY  SOURCE  SEPARATION  , 2E21 . 1 3) 

CALL  LRRXIT 

C 1/2  SOURCE  TO  SINK  SEPARATION 

40  RBSEP2  = SQRT(SQA) 

C SOURCE  STRENGTH  (VOLUME/TIME) 

RBSTR  = PI*B0DSPD*SQBD2*SQRT (SQA+SQBD2)  /RBSEP2 
C 

50  IF  ( I BODY  .NE.  2 .AND.  IPBODY  .NE.  2)  GO  TO  60 
C DIPOLE  BODY.  RBLIM=LIM{ RBSEP2*KBSTR)  AS  RB  SEP  2 GOES  TO  0 

RBL1M  = P I *BODS  PD*  80DD I A**  3 /8. 

60  RETURN 
END 

SUBROUTINE  CAS  El 

C ONCE  PER  CASE  IN  IT  IAL I L AT  ION 

C 

COMMON  / BGDY/  I BODY , IPBODY,  BODDEP , BODDIA,  BUDLEN,  BODSPD 
1,  RBSEP2,  RBSTR,  RBLIM 

C 

COMMON  /CONTRL/  ICASE,  ICKFLG(ZO),  JDISP,  JFFT,  JPOT 
1,  NODISP,  NOGRIC 

EQUIVALENCE  (MODS  E A,  ICK  FLG(  1 )) , ( MOUOBS, ICKFLG ( 2 ) ) 

1,  ( MODBOD,  ICKFLG(  3 )),  ( MQDWAK , ICKFLG ( 4 )) , ( MODSUP , I C KF LG ( ? ) ) 

C 

COMMON  /GRID/  OBSDEP,  NOBS,  DOBS,  OBSMAX,  TABOBS(IOO),  ITHOBS 

1,  X,  CX,  X MIN,  NX,  IT  HX,  Y,  DY,  YMIN,  NY,  ITHY,  MODE  1 , MODEN 

2,  IVAR,  IPRCT , IPP  DT ( 9 ) , XPMAX,  YPMAX,  IPPPSD,  I PREOG 

3,  ISPHAS 
C 

COMMON  /SUPER/  ISUPR,  SJPTOP,  SUPBOT,  IPSUPR,  SUSTR,  SUSEP2 
I*  SUPMID,  SULIM,  SUPDIA,  SUPLEN 

C 

common  /wake/  iwake,  cwakr,  cwakx,  xwake,  wakrao,  xwnom 

1,  RESLVS,  CWAKM 


SET  JOISP--  0=  NO  DISP  REQUIRED,  1=REC0MPUTE  DISP  TABLE 
JDISP  = 0 

C INPUT  FLAG  TO  BYPASS  DISP  TAB  OVER  IDES  ALL  ELSc 

IF  (NODISP  .NE.  0)  GO  TO  10 
C SKIP  IF  NO  F FT  OR  STATIONARY  PHASE 

IF  ( IBODY+IWAKE+ISUPR  . EQ.  0)  GO  TO  10 
C RECOMPUTE  IF  OCEAN  WAS  CHANGED 

IF  (MODSEA  .NE.  0)  JDISP  = 1 
C ...IF  OBSERVATION  DEPTH  WAS  CHANGED 

IF  (NOBS  .GT.  1)  MODOBS  = 1 


IF 

(MODOBS 

.NE.  0) 

JDISP 

= 1 

C 

• • • 

IF  BODY 

PARAMETERS  WERE 

CHANGED  AND 

BODY 

IS 

ON 

IF 

(MODBOD 

.NE.  0 

.AND. 

IBODY  .NE.  0 

) JDI 

SP 

= 1 

c 

• • • 

IF  WAKE 

PARAMETERS  WERE 

CHANGED  AND 

WAKE 

IS 

ON 
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I 
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] 


IF  (MODWAK  .NE.  0 .AMD.  IWAKC  .NE.  0)  JDISR  = 1 
C ...IF  SUPLRST  RUCT  JRE  PARAMETERS  WERE  CHANGED  AO  SUPR  IS  ON 

IF  (MODSUP  .NE.  0 .AND.  ISUPR  .NE.  C)  JUISP  = 1 
C 

10  JFFT  = 0 

JPOT  =0  • 

C INPUT  FLAG  TO  BYPASS  GRID  COMPUTATION  JVERIDES  ALL  ELSE 

IF  (NUGRIC  .NE.  0)  GO  TO  220 
C JUMP  IF  USING  STATIONARY  PHASE 

IF  (ISPHAS  .Nt.  0)  GO  TO  220 
C USING  FFT  (AND/OR  POTENTIAL) 

C SET  JFFT --  0 = t\0  FFT,  1=JSING  FFT 

IF  ( I BODY+ISUPR+IWAKL  . Nt.  0)  JFFT  = I 
C SET  JPOT — 0 = NO  POTENTIAL,  1 =P  0 T EN  T I AL 

IF  ( I P BODY  + 1 PSU  PR  .NE.  0)  JPOT  = 1 
200  IF  (NX  .IE.  1 .Ok.  NOBS  .EE.  1)  GJ  TO  220 
WR  I T6 ( 6 , 2 10 ) NX , NUBS 

210  F ORMAT  ( 39H  ERROR  — GOTH  NX  AND  N03S  GREATER  THAN  l,?I10) 

CALL  ERkXlT 
C 

C SKIP  IF  X-Y  SCAN  AT  CONSTANT  Z 

220  IF  (NOBS  .LE.  1)  GO  TO  <^60 
C PRESET  IN1ERNAL  INCREMENT  IN  OBS  DEPTHS 

CEL  = DCBS 

C IF  IT  WAS  INPUT,  JSt  IT  TO  CONSTRUCT  LIST  UF  DEPTHS 

IF  (DEL  .NE.  0.)  GO  TO  230 

C IF  MAX  DEPTH  IS  ALSO  ZERO,  LIST  WAS  INPUT  DIRtCTLY 

IF  ( CBS  M AX  .EC.  0.)  GO  TO  250 

C COMPUTE  INCREMENT  FROM  INPUT  MAX,  MIN  AND  NUMtJcR  UF  POINTS 

DEL  = (ObSMAX-TABOBSm  ) / FLOAT(NOiS-l) 

C CONSTRUCT  EQUAL  INCREMENT  TABLE 

230  DO  2+0  1=2, NGBS 

2 40  TABCBSII)  = TABUBS(I-l)  + DEL 
250  CBSDEP  = I A B 0 3 S ( 1) 

260  CONTINUE 
RETURN 
END 

SUBROUTINE  ENDRJN 
C END  OF  RUN  PkUCEDJRF 

C 

COMMON  / 2RT Pi T / IPLTON,  XAORG,  YAORG,  XPORG,  YPORG 


C 

c 

C SKIP  IF  NC  PLOT  ING  FAS  BEEN  CONE 

IF  (IPLTON  .EQ.  0)  GO  TO  10 
C WRAP  UP  PLOTS 

CALL  P LOT ( 0 . , 0.,  999) 

10  CONTINUE 
CALL  EXIT 
END 

SUBROUTINE  FRRXIT 
C ERROR  EXIT  PROCEDURE 

CALL  ENDRUN 
END 

SUBROUT  I NE  SET  ID(  ID,  IT,  PN,  VI,  FN  ) 

C PRESET  PP  ID  BLOCK 

C 

COMMON  / PPCOM/ 

1 LENPP,  PNAME , PMIN,  PMAX,  PLEN,  VNAME , VMIN,  VMAX 

2,  VI.EN,  FN  AME(  2 ) , FMIN,  EM  A X , FLFN,  FTODP,  TITLEI2) 

3,  I CCU  R,  IPLTYP,  IPL01,  IRRINT,  IEDIT,  NP,  IVLIST,  NOPP 

4,  I DPP , NV,  ISYM 
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E,  ENDPP,  I BLOKS ( 1 ) 

01  MENS  ION  FN { 2 ) 

DATA  BIG/1.  L30/ 


JUHP  IF  PREVIOUS  OUTPJT  SET  IS  FINISHED 
IF  1 ! DPP  .EG.  IH  ) GO  TO  20 

A PP  6ET  IS  STILL  IN  P * DGR ES S-- DQNT  START  ANOTHER 
WRITEIfa.IO)  I D PP » ID 

10  FORMAT (35H  FILE  CUNFLICT  DUE  TO  PROGRAM  ERROR , A 1 0, 3 X , A 1 0 ) 

CALL  ERRXIT 
PLOT  ID 
20  IOPP  = ID 

PLOT  TYPE--  0=  RAS  T ER»  1 =MUL T I- TRACE 
I PLTYP  = IT 

PARAMETER,  VARIABLE  AND  FUNCTION  NAMES 
PNAME  = PN 
V NAME  = VN 
F NAME  I 1 ) = h N ( 1) 

FNAMEI2)  = FN( 2 ) 

PARAMETER,  VARIABLE  ANO  FUNCTION  MAXIMA  AND  MINIMA 
PMAX  = -BIG 
VM AX  = -BIG 
FMAX  = -BIG 
PMIN  = BIG 
VMIN  = BIG 
FMIN  = BIG 

C PARAMETER,  VARIABLE  AND  FUNCTION  AXIS  LENGTHS 

PLEN  = 10. 

VLEN  = 10. 

IF  ( I PLTYP  .EQ.  0)  VLEN  = 8. 

FLEN  = 8. 

C 

TITLE(l)  = 1H 
TITLEI2)  = IH 

C CCCURANCE  NUMBER  IS  IGNORED 
IOCUR  = 0 

C I PLOT--  0=UFF,  1 = PLOT 

I PLOT  = 1 

C IPRINT—  0=CFF , 1=  PR  INT  ALL,  2 = SUMMAR  Y,  3 = 1 + 2 

IPRINT  = 2 

C EDIT  FLAG  IS  IGNORED 

IEDIT  = 0 

C SUPPRESS  PP  IS  IGNORED 

NOPP  = 0 

C ISYM  0 = NO  SYMBOLS,  1 = L AB  EL  TRACES  ON  A MULTI-TRACE  PLOT 

ISYM  = 0 

C FOR  RASTER,  COMPUTE  FLEN  FROM  FLEN=FT0DP*PLEN/(NP-1  ) 

FT  OOP  = 1. 

C NUMBER  OF  PARAMETER  VALUES 

NP  = 0 

C {MAX)  LENGTH  OF  VARIABLE  LIST 

NV  = 0 

C IVLIST—  1=  EQU  AL  INC,  2 = FIXED,  3=VAR  I ABL  E 

IVLIST  = 1 
RETURN 
END 

subroutine  SUP R 1 

C COMPUTE  SUPERSTRUCTURE  SOURCE  PARAMETERS — STRENGTH  ANO  1/2  SEP 

c 

COMMON  /BODY/  IBOOY,  IPBODY,  BODDEP , BOODIA,  BOOLE N , BODSPD 
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1,  RBS  LP2 , RBSTK,  RBLIM 

C 

COMMON  /CONST/  JDK,  JDMODE , JDTCL,  PI,  NULL,  JDCKL , JDMF  T 
1,  JDCKSV , JDMSP,  JDEDGE 

C 

COMMON  /SUPER/  ISUPR,  SJPTOP,  SUPBOT,  IPSUPR,  SUSTR,  SUSEP2 
1,  SUPMIC,  SULIM,  SJPCIA,  SUPLEN 


TEST  SUPERSTRUCTURE  MODEL 

IF  (ISUPR  .NE.  1 .AND.  IPSUPR  .NE.  1)  GO  TD  50 
CVAL  CRCSS  SECTION 
C2  = SJPDIA/2. 

rl:  = suplen/2 • 

SULZ  - RL2  * *2 
P I 2 = PI/2. 

INITIAL  GUESS  FOR  SUSE?  2 (SJSLP2  IS  1/2  SUURofc  SEPARATION) 
SUSFP2  = RLZ  - SUPDI  A/(  2.«FI  ) 

ITERATE  TC  FIND  SUSEP2 
DO  20  1=1,20 

CLDSEP  = SUSEP2 

SUSEP2  = S ORT ( SQLZ  - S J S EP 2* D2/ ( P I 2- AT AN ( D 2/ SU SE P2 ) ) ) 

20  IF  ( ABS (SUSEP2-0LDSEPI/RL2  .LE.  1.E-1C)  GO  TU  AO 
WRIT  E( 6 , 30  ) SUSCP2, OLDSEP 

30  FORMAT (A1H  NC  CONVERGENCE  ON  SUPR  DURCE  SEP AR  A TI  GN  , 2 E 2 1 . 1 ? ) 
CALL  ERRXIT 

SOURCE  STRENGTH  ( V OLUM E/T I ME/L ENGT H ) 

AO  SUSTR  = P I *80USP D* ( S0L2/SUSEP2-SUSEP2) 

50  IF  (ISUPR  .NE.  2 .AND.  IPSUPR  .NE . 2)  GO  TO  60 

CIRCULAR  SECTION.  SUL  I M=L IM ( SU STR #SUSEP 2 ) AS  SUSEP2  GOES  TO  0 
SULIM  = P I *BOUSP D* ( SUP D I A/ 2.  )**2 
60  RETURN 
END 

SUBROUT INE  T I M ER ( ID) 

COLLECT  AND  PRINT  TIMING  INFORMATION  FDR  SELECTED  SUBROUTINES 
DI  MENS  ION  T IMES(  20  ),  NAMLS(20),  TSTRT(20> 

DATA  TCASE/-1./ 

DATA  T I MES / 20  *0  ./ 

DATA  NAMES/5HINC0N,  5HDTCDN,  6MDTEVAL , 6HDTEVEC,  6HDTDER2 

1,  6HDTWAKE,  5HFTC0N,  6HFTDTAB,  6HFT3EN0,  oHFTNEWX,  5HFTFFT 

2,  5HFTP0T,  5HPPC0N,  5HSPC0N,  6HSPDTAB,  6HSPWFAM,  6HSP1PNT 

3,  3*1U  / 

I ABS (ID)  IS  INDEX  NUMBER  DF  ROUTINE  BEING  TIMED 

ID  .GT.  0 = START  OF  RDJTINt,  ID  .LI.  0 = END  OF  ROUTINE 

ID  .EQ.  0 = START  OF  NEW  CASE 


I = I ABS( ID) 

C RETURN  IF  ILLEGAL  INDEX  VALJE 

IF  (I  .GT.  20)  RETURN 
IF  (ID)  20,30,10 
C 

10  CALL  SECONU( TSTRT ( I ) ) 

RFTURN 

C 

20  CALL  StCONO(TcND) 

TIMES(I)  = TIMES(I)  + T END-T STRT(  I ) 
RETURN 
C 

30  CALL  SECOND! T ) 

C SKIP  IF  START  OF  1ST  CASE 
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IF  (TCASfc  .LT.  0.)  GO  TO  80 
TCASE  = T-TCASE 
WRITE(6,50)  TlASE 

50  FORMAT (9H1CP  TIMES/5H  CASE,F15.3) 

CO  70  1=1,20 

IF  (NAME’S  ( I ) .NE.  1H  ) WRITE(6,6C)  N />  M _ S ( I ) , TIM  ESI  I ) 


SO  FORMAT ( 1H  , AlO, F9. 1 ) 

70  TIMES ( I ) = 0. 

BO  TCASE  = T 
RETURN' 

End 

SUBROUTINE  W RT  DAT  (LOCI,  LUC  2,  FL  I ST , 1 N C ,P VAL  ) 
WRITE  FP  DATA  KECURC  AS  SUM  IN G 1 VL  1ST  .ME.  3 


f I N3  MI N AND  MAX 


COMMON  /FILES/  NT  IL  IB,  NTDLIB,  NTPDEF,  MTPID,  UPUAT,  NTPLOT 
1,  NTCTAB,  NT  EV  EC,  NTTEMP 


COMMON  /PPCCM/ 

1 LCNPP,  PNAM  t , PMIM,  PMAX,  PLlM,  VMAME,  VMIN,  VMA). 

2,  VLEN,  FN  AM  E ( 2 ) , F M IN , FM  AX  t FlEN,  FTODP,  TITLE  ( 2 ) 

3,  ILCUR,  1PLTYP,  1PL0T,  IPRINT,  ItDlT,  NP , 1VLIST, 

4,  I DPP , NV,  ISYM 

E,  ENDPP,  1 RL  OK  S ( 1) 

01  MENS  ION  FL  1ST ( 1 ) 


NOPP 


BUMP  NUMBER  OF  PARAMETER  VALUES 
NP  = N P* 1 

ADORES  S OF  loT  ENTRY  IM  FLIST 
11  = ( LCC1-1 ) * INC  + 1 
ADDRESS  OF  LAST  ENTRY  IM  FLIST 
LAST  = ( L0C2- V ) * INC  ♦ 1 

WRITE  PP  CATA  RECORC  (ASSUME  IVLIST  .NE.  3) 

WRITE(NTPOAT)  PV AL, LOCI, L0C2,!FLIST(  I), 1=11, LAST, 'NC) 

FI ND  MAX  AND  MIN 
DO  10  1=  I 1, LAST , INC 

IF  (FMAX  .LT.  FLIST(I))  FMAX  = FlIST(l) 

10  IF  (FMIN  .GT.  FLIST(I))  FM I N = FLIST(I) 

IF  ( PM AX  .LT.  PVAL)  PMAX  = PVAL 
IF  ( PM  I N .GT.  PV ; L ) P M IN  = PVAL 
RETURN 
END 

SUBROUTINE  WR T 03 < NWORD S , VL 1ST, FLIST, INC, PVAL) 

WRITE  PP  DATA  RFCURC  ASSUMIMG  I VL  I ST  = 3 FIND  MIN  AND  MAX 


COMMON  /FILES/  NTILIB,  MTDL1B,  NTPDLF , MTPID,  NT  PL1  A T , NTPLOT 
1,  NT0TA8,  NIC1.' EC,  NTTEMP 


COMMON  /PPCCM,/ 

1 LENPP,  PNAME,  PMIN,  PMAX,  PLLM,  VMAME,  VMIN,  VMAX 

2,  VLEN,  F.NAMEI  2) , FMIN,  FMAX,  FLEN,  FTODP,  TITLE  ( Z ) 

3,  ICCUR,  IPLTYP,  I P LOT  , IPRINT,  1EDIT,  NP,  IVLIST,  NOPP 

4,  ICPP,  NV,  IS  YM 

E,  ENDPP,  I BLOKS ( 1 ) 

DIMENSION  VL  IS  T ( 1),  FLIST!  1) 


BUMP  NUMBER  OF  PARAMETER  VALUES 
NP  = NP+1 

ADDRESS  OF  LAST  ENTRY  IN  VLIST,  FLIST 

LAST  = { NWORCS  -1  ) • INC  ♦ 1 

WRITE  PP  DATA  RECORC  (ASSUME  IVLIST-3) 
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WRITE! NT  PD AT ) PV AL , NWD R DS , ( VL I ST (I ) , F L I S T (1) , I =1 , L A ST , I NC ) 
C FIND  MAX  AND  MIN 

DO  10  1=1, LAST,  INC 

IF  ( FM AX  .LT.  FLIST(I))  FMAX  = FLIST(I) 

IF  (FMIN  .GT.  FLIST(I))  FM  I N =FLIST!I) 

IF  UMAX  .LT.  VLIST(I))  VMAX  = VLISTII) 

10  IF  (VMIN  .GT.  VL  IS  T ( I ) ) VMIN  = VLISTII) 

IF  ! PM  AX  .LT.  PV  AL  ) PMAX  = PV  AL 

IF  ( PM  IN  .GT.  PV  AL ) D M IN  = PVAL 

RETURN 
END 

SUBROUTINl  WRT  IDIN.VLIST, INC > 

C WRITE  OUT  THE  ID  RECORD! S)  FUR  CURRENT  PP  SET 


C 

COMMON  /FILES/  NTILIB,  NTULIB,  NTPDtF , NTPID,  NTPOAT,  NTPLOT 

1,  NT DT  A B , NT  EV  EC,  NTT  EMP 
C 

COMMON  /PP(  cm/ 

1 LENPP,  PNAME , PMIN,  PMAX,  PLEN,  VNAME , VMIN,  VMAX 

2,  VLEN,  FNAMEI2),  FMIN,  FMAX,  FLEN,  FTODP,  TITLLI2) 

3,  IOCUR,  IPLTVP,  I PLOT  , IPRINT,  IEDIT,  NP,  IVLIST,  NOPP 

4,  I DPP , NV,  ISYM 

E,  ENCiPP,  I BLOKS  ! 1 > 

DIMENSION  IDBLCKll),  D JMMY ! 1 ) , VL  I ST  C i ) 

EQUIVALENCE  t DUMMY,  LENPP  ) , I I DBLUK , DUMMY  I 2 ) ) 

C 

C 

C SET  LENGTH  CF  ID  BLOCK 

LENPP  = LUCFUNUPP)  - L DCF  I LENPP' 

C SET  NUMBER  OF  ENTRIES  IN  VARIABLE  LIST 

NV  = N 

C SKIP  IF  VARIABLE  LISTIS)  PREVIOUSLY  DEFINED 

IF  IIVLIST  .Nc.  2)  GD  TO  20 
C VLIST  IS  IN  CALLING  SEC.  FIND  MAX  AND  MIN 

LIM  = ! NV-1  ) * INC  ♦ 1 
DO  1.0  I~  i , L I M,  INC 

IF  ! V M AX  .LT.  VLISTII))  VMAX  = VLISTII) 

10  IF  IVMIN  .GT.  VlISTID)  VMIN  = VLISTII) 

C WRITE  ID  RECORO 

20  WRITEINTPID)  LLNPP,  ! IDBLOKI  I ),  I = 1,  LLNPP  ) 

C 

IF  IIVLIST  .EQ.  2)  WRITEINTPID)  I VL I ST (I) , I =1 , L I H , I NC ) 

C FLAG  ROUTINE  S ET  I D THAT  THIS  PP  SET  HAS  BEEN  COMPLETED 

I DPP  = 1H 
RETURN 
END 

SUBROUTINE  OTCON 
C DISPERSION  TABLE  CONTROL 

C 

COMMON  / BCDY/  I BODY , IPBODY,  BODDEP,  BODDIA,  BUOLEN,  BODSPD 
1,  RBSEP2,  RBSTH,  RBLIM 
C 

COMMON  /FILES/  NT IL  IB,  NTDLIB,  NTPDEF , NTPID,  NTPDAT,  NTPLOT 
1,  NT  DT  AB , NT  EV  EC,  NTTEMP 

C 

COMMON  /GRID/  08SDEP,  NOBS,  DOBS.  ObSMAX,  TABOBS(IOO),  ITHOBS 

1,  X,  UX,  XMIN,  NX,  ITHXv  Y,  DY , YMIN,  NY,  ITHY,  M0DE1 , MODEN 

2,  IVAR,  IPRDT , I PI’DT  ( 9 ),  XPMAX,  YPMAX , IPPPSD,  I PREDG 

3,  ISPHAS 


C 


COMMON  /OCEAN/  LlBoEA,  MOOES , NK,  TABKIIOO),  NZT,  DKRAT,  DTDEP 
1,  TDEPMX,  TDEP('tOO),  NFL  AG,  SOBVIAOO),  OCNDEP,  RKMAX 
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2, 


S ON ( 400 } i NKT,  IPPVFC 


COMMON  / PPCGM/ 

1 LFNPP,  PNAMF,  PMIN, 

* VLEN,  FN  AM  E ( 2),  FM  IN 

i IUCUR,  1PLTYP,  I P LOT 

* IOPP,  NV,  I S YM 

» :nopp,  i bloks ( 1 ) 


PM  AX  , PI.EN,  VNAME,  VMIN,  VMAX 

♦ FMAX,  FLEN,  FTODP,  TITLE  (2) 

* IP  R I N T » I d D I T , NP,  I VL  1ST,  NOPP 


COMMON  /SUPER/  ISJPR,  SJPTOP,  SUPBOT,  IPSUPR,  SUSTR , iUSEPl' 

* SUPMIU,  SULIM,  SJPLIA,  SUPLEN 

COMMON  / w AK  t/  IWAKE,  CWAKP,  CWAKX,  XWAKE  , WAKRAD,  XWNCM 

* RESLVS , CWAKM 


COMMON  //  RK,  ITHK,  ZT  ( 400  ),  LWAVEC,  NZT1,  NZ  T<_ , ZT1D 
* ZTN,  ITOP,  I BO  T , SQ< , TOPI,  TOP,.,  TUP  3 , T0P4,  T0P7  , TQP3 

BCT1,  BOT  2 , B0T3,  B0T4,  B0T7,  30T8,  IERR,  010  (400) 

NT  RUT , Z,  ZS,  TEVAl(4C0>.  T0L0KI80),  TP3BSI80) 

TCPLBS(dO),  TCPSRCI30),  TWII30),  TPSUPT(oO),  TPSUPR(BO) 

T 0L0K2  ( t)0  ) , EVECI 400,80),  TEMP ( 400, 5 ) , 00(400) 

T R I M AT  ( 400 , 3 ) , SU(400),  SDL(400),  S0L2(400),  DLKOO),  D(400) 
0U(400),  CONIwOO),  (IMfc  G(  400  ) , BND(4CC),  IEVAH400) 

EV3  P ST ( HO  ) , PSIN2II80) 

•••••SJMMARY  Or  APPROACH***** 

EACH  ENTRY  TO  OT  CON  GENERATES  A COMPLETE  DISPERSION  TABLE  (DT) 

CN  FILE  NT  DT  AH . FOR  EACH  VALUE  OF  WAVENUMBER  K,  THE  FILE  HAS 
A RECORD  CONTAINING  K, T EV AL ( M ) , TDLDK ( M ) , TPOB S ( M ) , TD POB S ( M ) , 

TOPSRC ( M ) , TW I ( M ) , TSUPT ( M ) , TSUP B ( M ) , TDLDK2( M ) WHERE  INDEX  M (S  THE 
MODE  NJMBEH.  THESE  ARE  EIGENVALUE  LAMBDA  = I /O*  * 2 , D ( LA  MT  D \ ) /DK  , 
PSIIOBS  DEPTH),  DIPSH/DZIOBS  DEPTH),  D ( P S I ) /D  Z ( SOURC  b DEP), 
PARTIAL  WAKE  SOURCE  TERM,  PS I(  TOP  OF  SUPER),  PSIIBOTTOM  OF  SUP), 

D2 ( LAMBDA ) / DK2  WHERE  PSI  = E IGEN VECTOR. 

CN  THF  FIRST  CASE,  1 HE  EIGENVALUES  MAY  BE  READ  FROM  A FILE 
GENERATED  AND  SAVED  DJRING  A PREVIOUS  RUN.  FOR  SUBSEQUENT  CASES, 
THE  INPUT  PROCESSOR  EXAMINES  THE  INPUT  VARIABLES  TO  DETERMINE 
WHAT  HAS  BEEN  CHANGED  AND  SETS  FLAGS  (PREFIXED  BY  THE  LETTERS 
MOD)  INDICATING  WHICH  3 F THE  DT  VARIABLES  WILL  3E  AFFECTED.  TO 
MINIMIZE  REDUNDANT  COMPUTATIONS,  BOTH  THE  DT  AND  A FILE  WITH  THE 
COMPLETE  SET  OF  EIGENVECTORS  ARE  AVAILABLE  FROM  THE  PREVIOUS  CASE. 


CALL  T I ME R ( 2 ) 

OT  INIT  IALIZAi  ION 
CALL  DT INIT 

JPPVEC--  0=0FF , 1=PRT/?LT  EIGENVECTOR  WITH  MODE  NUk>:R  OF  JPPVFC 
JPPVEC  = 0 

IF  (ITHOBS  .EC.  1)  JPPVEC  = IPPVEC 
SKIP  IF  OPT  ION  IS  OFF 
IF  (JPPVEC  .EG.  0)  GD  TO  5 

CALL  SET  I U ( 4HEVF C , 0,  1 HK,  5FDEPTH,  20HE iGENVECl OR  ) 

I VL I ST  = 2 
CONT  INUE 

LOOP  FOR  EACH  VALUE  OF  WAV  f NUMBER  K 
DO  10  I THK= 1 , NKT 

COMPUTE  EIGENVALUES  LAMBOA  (ALL  SPECIFIED  MODES) 

CALL  DT  tV  AL 

JUMP  IF  ROUTINE  COULD  NOT  DO  IT 
Ir  (I  ERR  ,NE.  0)  GO  TO  40 
COMPUTE  CORRESPONDING  EIGENVECTORS  PSI 
CALL  DTEVLC 
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JUMP  IF  ROUTINE  COULD  NOT  DO  IT 

IF  ( I ERR  .NE.  0)  GO  TO  40 

D<  L AMBDAI/DK 

CALL  DTUER 

C * *2 ( LAMBDA)/ CK**2 

CALL  DTCER2 

JUMP  IF  2 \D  DcRIV  COULD  NOT  BE  FOUND 
IF  (IERR  .NE.  0)  GO  TO  40 
P.'>I  AND  DIPSD/CZ  AT  OBSERVATION  DEPTH 
CALL  DTCBS 

DIPSD/DZ  AT  SOURCE  DEPTH 

IF  I I BODY  .NE.  0)  CALL  DTrtDDY 

(PARTIAL)  WAKE  SOURCE  TERM  I INCLUDES  INTEGRAL) 

IF  (IWAKF  .NE.  0}  CALL  CTWAKE 
PS  I AT  TUP  A\U  BOTTOM  OF  SUPERSTRUCTURE 
IF  (IoJPK  .NE.  0)  CALL  DTSJPR 
WRITE  EIGENVECTOR  IF  CALLED  FOR 

IF  (JPPVEC  .NE.  0)  CALL  W R TO  AT  ( 1,  NZ I , E V EC  < N Z T*  JPP  VE  2 -N  ZT+  i ) ,1  , RK) 
SAVE  DISPERSION  TABLE,  GENERATE  NEW  DT  LIBRARY  IF  OCEAN  CHANGED 
10  CALL  DTWRIT 

WAIT  FOR  LAST  SET  OF  EIGENVECTORS  TO  BE  WRITTEN  BEFORE  CONTINUING 
20  IF  (UNIT  * NTEVEC ) 20,30,30,30 

30  IF  (JPPVEC  .Nfc.  0)  CALL  WRTIDINZT,  ZT,  1) 

CALL  T I MER ( -2 ) 

RETURN 

FATAL  ERROR  IF  E I GENV AL JE/VECTOR  ROUTINES  BOM3E3  EARLY  IN  DT 
40  IF  IITHK  .LT.  NKT/3)  CALL  ERRXIT 

(TRY  TO)  MAKE  CO  WITH  AS  MUCH  OF  CT  AS  THERE  IS 
NKT  = ITHK-1 

WR I TE ( fc  * 50 ) NKT,TA8K(N<T  ) 

50  FORMAT ( 3 1 H K TABLE  T R J N CAT  ED  AT  ENTRY  N0.,I4,3H  K=,E14.7) 

GO  TO  20 
END 

FUNCTION  DTAVEN(DIA) 

COMPUTE  AVERAGE  BV  FREQ  OVER  C I AMETER  =D  I A CENTERED  AT  ZS 

COMMON  /OCEAN/  LIBSEA,  MOOES,  NK , TABK(IOO),  NZT,  DKRAT,  DTDEP 

1,  TDEPMX,  T DEP ( 400 ) , N FL  AG , SQ3V(400)f  OCNDEP,  RKMAX 

2,  SQN( 400 ) , NKT,  IPPVEC 

COMMON  //  RK,  ITHK,  ZT(400),  LWAVEC,  NZT1,  NZT 2 , ZT1D 

1,  ZTN,  HOP,  I BUT , SO*,  TOPI,  T0P2,  T0P3,  T0P4t  T0P7 , T0P8 

2,  B0T1,  BUT  2 , 80T3,  B0T4,  B0T7,  B0T8,  I ERR  . QIC  (400) 

3,  NTRCT,  Z,  ZS,  TEVAL(4C0),  TDL  l)K  ( 80 ) , TPJBS(80) 

4,  T DPG 8S ( 80 ) , TDPSRC(BO),  TW I ( 80 ) , TPSUPT(80),  TPSUPBI80) 

5,  T DL  0K2 ( 8 0),  EVEC( 400, 8 C ) , TEMP(400,5),  DC(400) 

6,  TR I M AT  ( 400 , 3 ) , S0(400),  SDK400),  SDL2(400),  DL(400),  D(400) 

7,  DU(AOO),  CONI  400  ) , 0MEG(  400),  BND(400),  IcVALUOC) 

8,  EV3PST(80),  PSIM2II80) 


UPPER  AND  LOWER  L IMITS 
Z'.  * ZS  - DI  A,  2. 

ZU  = ZS  ♦ 01  A/ 2. 

trapezoical  INTEGRATION  OF  n FROM  ZL  TO  ZU 
AVE  = 0. 

Zll  = ZL 

IF  (ZL  .LT . ZT ( 1 ) ) Zll  = ZT ( 1 ) 

DO  10  1 = 2, NZ  T 
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10  IF  (Zll  .LT.  ZT( m GO  TO  20 
C N AT  LOWER  LIMIT 

20  BV1I  = SORT ( SQN ( I - I ) ) 

BVI  = SORT ( S ON ( I ) ) 

8VI1  = BVli  + (BVI-BVI1)  / ( ZTC  I)  — ZT(  I — 1)  ) * ( Z I 1- Z T ( I -1 ) ) 

00  30  J=1,NZT 
BVI  = SORT  ( SG.M  ( J )) 

IF  ( ZT ( J ) .GE.  Z U > GO  TO  AO 

AVE  = AVE  ♦ .5»(  6VI  + BV  I 1)*(ZT(  J )-ZU) 

BV  1 1 = BVI 
30  ZII  = ZT(J) 

GO  TO  50 
C 

c N AT  UPPER  LIMIT 

AO  BVI  = BVI 1 ♦ (RVI-HVI1)  / (ZT(J)-ZIl)  * (ZU-ZI1) 

AVE  = AVE  + .5  *(  BV  I+BV  I 1 )*  ( ZU-Z  1 1 ) 

50  DTAVEN  = AVE/(ZU-ZL) 

RETURN 

ENO 

SUBROUTINE  CTBODY 

C COMPUTE  DERIVATIVE  C(PSI)/DZ  OF  EIGENFUNCTION  AT  SOURCE  OiPTH 

C 

COMMON  /CONTRL/  ICASE,  ICKFLG(20),  JD1SP,  JFFT,  JPOT 
1,  NOCISPt  NOGRIC 

EQUIVALENCE  ( MODS EA, IC< FLG( 1 ) ) , ( MODOBS, ICKFLG ( 2 ) ) 

I,  (MODQOD,  ICKFLGC3)  )»  ( MOUWAK , ICKFLG ( A ))  , ( MOD  SUP  , I CKF  LG  ( 5 ) ) 

COMMON  /OCEAN/  LIBSEA,  MODES,  NK,  TAbK(IOO),  NZT,  OKRAT,  OTDEP 

1,  TDEPMX,  TDEP(AOO),  N FL  AG,  SQBV(AOO),  UCNDEP,  RKMAX 

2,  SON(AOO),  NKT,  IPPVtC 
C 

COMMON  //  RK,  1THK,  ZT(AOO),  LWAVEC,  NZT1,  NZT2,  ZTID 

1,  ZTN,  ITOP,  1 BOT , 5 UK , TOPI,  T0P2,  T0P3,  TOPA,  TUP7,  T0P8 

2,  BQT 1 , 0GT2,  B0T3,  BOTA,  B0T7,  B0T8,  I ERR  , QIC(AOO) 

3,  NTRDT , Z,  ZS,  TEVAL(AOO),  TDLDK ( 80 ) , TPO^S(BO) 

A,  TDP0BS(80),  TOPS  R C(  8 0),  TWI(80),  TPSUPT(80),  TPSUPB(80) 

5,  TDLDK2 ( 80 ) , EV EC ( AOO , 80 ) , TEMP(A00,5),  DC(ACO) 

6,  T RI MAT  ( AOO, 3 ) , SD(AOO),  SDL(AOO),  SDL2(AOO),  DL(AOO),  D(AOO) 

7,  DU ( AOO ) , CONI AOO  ) , OMEG(AOO),  BND(AOO),  IEVAL(AOO) 

8,  EV3PST ( 80 ) , PS  IN  2 II 80 ) 

DIMENSION  DUMMY  ( 3 ) , CDP  ( 3 ) 

C 

C 

c RETURN  IF  SAME  AS  PREVIOUS  CASE 

IF  (LI 8SEA+M00S  EA+MODBOD  . E3  . 0)  RETURN 
C GET  COEFFS  FOR  COMPUTING  D(PSI)/DZ  AT  SOURCE  DEPTH 

C CN  1ST  PASS  OK  IF  OUTSIDE  TCLINE 

IF  ( IT HK  .EQ.  1)  IND  = 0 

IF  (INO  .LE.  0)  CALL  DTPSICIZS,  IND,  DUMMY,  CDP) 

C COMPUT  E DC  PS  I ) / DZ  AT  SOURCE  DEPTH 

CALL  DTPSI (TCPSRC,  IND,  CDP) 

RETURN 

END 

SUBROUTINE  DTDER 

C COMPUTE  DERIVATIVE  OF  EIGENVALUE  LAMBDA  WRT  K 

C 

COMMON  /CCNTRL/  ICASE,  ICKFLGC20),  JDISP,  JFFT,  JPOT 
1,  NODISP,  NOGRID 

EQUIVALENCE  (MODSEA, ICKFLG(l))*  ( MODOBS, ICKFLG ( 2 ) ) 

1,  ( MOCBOC, ICKFLGt  3 ) ),  (MODWAK, ICKFwG(A) ) , ( MOD  SUP  , I C KF LG ( 5 ) ) 

COMMON  /OCEAN/  LIBSEA,  MODES,  NK,  TABK(IOO),  NZT,  OKRAT,  OTOE P 
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1,  TDEPMX,  TDEP ( 400 ) * NFLAG,  SQBV(400),  OCNDEP,  RKMAX 

2,  S QN ( 400 ) * NKT,  IPPVEC 
C 

COMMON  //  PK»  ITHK,  ZT(400),  LWAVEC,  NZT1,  NZT2,  ZT1D 

1,  ZTN,  ITGP,  fflOT,  SCX,  TOPI,  TUP  2,  T0P3,  TUP4 , T0P7  , T0P8 

2,  BOTL,  BUT  2 , B01  3,  B0T4,  BOT"7  * B0T8,  I ERR  , 010(400) 

3,  NT  ROT , l,  ZS,  TE/AL14C0),  TDLDK  ( 80 ) , TP33S(80) 

4,  TDPOBS(dO),  TOPS  RC(  80)  , T W I ( 80),  TPSUPT(oO),  TPSUPB(BO) 

5,  TDLLK2(oO),  EV EC< 400 ,8 0 ) , TEMP(4CO,5),  DC(4C0) 

6,  TRIMATUOO,  3 ),  S0(  400) , SDU  400),  SDL2U0D),  0L(4O0),  0(400) 

7,  DO ( 400 ) , CUN ( 400  ) , 3ME  G(  400  ) , BND(4C0),  IdVAL(400) 

8,  EV3PST(80),  PSIN2K80) 

C 

C 

C RETURN  IF  NC  CHANGE  FROM  PREVIOUS  CASE 

IF  (MUDSEA  .EC.  0 .AND.  LISSEA  .EG.  0)  RETURN 
C D ( L AMR  D A ) / CK  WHERE  L AM  BOA=  1/ C*  *2 

C PS  I N2 I = NORMAL l Z ED  INTEGRAL  D F (PSI*N)«»2  COMPUTED  IN  DTEVEC 

DU  10  M0DE=1, MODES 

10  TDLDK ( MODE ) = 2 . *RK/ PS  I N2 I ( MOD E ) 

RETURN 

END 

SUBROUTINt  CTCER2 

C COMPUTE  2ND  DERIVATIVE  OF  El GENVALUc  LAMBDA  WRT  K 

C 

COMMON  t CEiNTRL/  ICASE,  IC<FLG(20),  JDISP,  JFFT,  JPOT 
1,  NOD  ISP,  NOGRIC 

EQUIVALENCE  ( MODS E A, IC < FLG ( 1 5 ) , ( M0D3BS, ICKFLb ( 2 ) ) 

1,  ( M0C8GC, ICKFLG(  3 ) ),  (MQDWAK,  ICKFLG(4)  ),  ( MODSUP , I C KF LG ( 5 ) ) 

C 

COMMON  /OCEAN/  LI6SEA,  MODES,  NX,  TABK(IOC),  NZT,  3KRAT,  D TOE  P 

1,  TDEPMX,  TDEP ( 400 ) , NFLAG,  SQBV(hOO),  OCNDEP,  RKMAX 

2,  SCNI400),  NKT,  IPPVEC 
C 

COMMON  //  RK,  IT  HK , ZT(400),  LWAVEC,  NZT1,  NZT2,  ZT10 

1,  ZTN,  ITUP,  I HOT , SOX,  TOPI,  T0P2,  TQP3,  TOP  4 , T0P7,  TOPS 

2,  BCTL,  BOT  2 1 B0T3,  B0T4,  B0T7,  B0T8,  I ERR , QICI400) 

3,  NT  RDT , Z,  ZS,  TEVAL(400),  TDLDX  (60)  , TPUBS(80) 

4,  T DPGBS  ( 30  ) , TDPSRC(80),  TWK80),  TPSUPT(80),  TPSUPB(60) 

5,  T DLUK2  ( 80  ) , EVEC  ( 4C0,  8 0 ) , TEMP  ( <,00,  5 ) » DC(400) 

6,  T RI MAT ( 400 , 3 ) , SD(400),  SDL(400),  SDL2(400),  DL(400),  0(400) 

7,  DUtnOO),  CON  ( 400 ) , 3MEG(400),  B\|0(400),  IEVAL(400) 

8,  EV3PST  ( 80  ) , PS  IN  21(80) 


RETURN  IF  NO  CHANGE  FROM  PREVIOUS  CASE  OR  IF  OERIV  WAS  READ 
FRCM  D.T.  LIBRARY 
IF  (MODSEA  .EQ.  0)  RETURN 
CALL  T I MER I 5 ) 

IF  ( RK  .NE.  0 . ) GO  TO  20 
C TAKE  LIMIT  FCR  K=0 

C PSIN2I  IS  NORMALIZED  INTEGRAL  OF  (PSI*N)»»2  COMPUTFD  IN  DTEVEC 

DO  10  M0DE=1, MODES 

10  TDLDK2  ( MODE)  = 2 ./PS  IN2  I(  MODE  ) 

GO  TO  100 
C 

20  TWOK  = RK  + RK 

TEMPT  = RK *ZTN  + T 0P8* ( 1 .-R< * Z TN* TOP  8 ) 

TEMPB  = RK*Zi'iO  + B0T8*( 1.-RK*ZT1D»bOT8) 

C LOOP  FOR  EACH  MODE 

DO  90  M0DE=1, MODES 

EVAL  = T EV  AL  ( MODE  ) 
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SUBTRACT  EIGENVALUE  FROM  DIAGONAL 


TO  SURFACE 
AUTOMATICALLY 


DLDK  = T OLDKI  MODE  ) , 

SET  UP  TRI-DIAGONAL  MATRIX  FOR  OM EGA  = D(  P SI ) /DK 

FWA-1  OF  EIGENVECTOR 
II  = (MODE-l)*NZT 

SAM^MATrI^AS^OR  PSI  BUT  SUBTRACT  EIGENVALUE  FROM  DIAGONAL 

DL(  I)  = TRIM  AT  ( I ) 

DU)  = TRIMAT  I I+NZT  ) - EVAL 
OUI1)  = T R IM  AT  ( I+NZT2) 

CON  ( ' ) = ( CLDK-TWOK/SQM  I)  )*  EV  EC(  ll+l  ) 

DU(NZTl)  = 0. 

clinirp  r^’INDARY  CONDITION  IF  TCLINE  DDES  NOT  EXTEND  TO  SURFACE 
°Suo“>!  SotE  6LEHEMTS  HAVE  BEEN  ADJUSTED  AUTCHATICA 

IF  (ITOP  . NE . 0)  CQN(NZTl)  = CON(NZTI) 

IF  IITUP  +EVEC!  !WNZT)»DUINZT1)*T0PWEMPT 

< i hpt  Nfc  0)  CONI  2 ) = CONI  2 ) ♦ EVECI I U 1 > *0L ( 2 ) *30TA. TEMPB 

NOT^MATRIX  FOR  OMEGA  IS  SINGULAR.  TO  REMOVE  SINGULARITY, 

Replace  one  cf  the  difference  equations  isay  at  point 

WITH  A NORMALIZAT ICN  EQUATION.  CHOOSE  OMEGA  I 3 ) =ID I PSI ) /OK  B 
FINITE  DIFFERENCE).  PRESET  NORMALIZATION  FOR  K = 0 

DPDK  =1.  

PICK  UP  EFUNCT  ION  AT  POINT  3 (FROM  TOP) 

^3(ITHKE^e1+1)T’o(1d<  = I EV  3-EV3P  STI  MODE  ) ) / (RK-TABKII  THK-l)  ) 

SAVE  EFUNCT ION  FOR  USE  AT  NEXT  K 
EV3  PST ( MODE ) = EV 3 
DLINZT-2)  = 0. 

DINZT-2)  = 1. 

OUINZT-2)  = 0. 

CONINZT-2)  = CPCK 


(RK-TABKII THK-l) ) 


SOLVE  SYSTEM  CF  EUUAT I DNS  FDR  OMEGA 
CALL  TRI0IDLI2),  0(2),  DUI2),  COM2), 

IF  (IERR  .EC.  0)  GO  TO  50 
WRITE  I S ,A0 ) MODE,  ITHK, RX 
FORMAT  I 33H  MA1RIX  FOR  0(  PS  I ) /D<  IS  SI 

SeVeNC^PCINTS  OF  OMEGA  FROM  BOUNDARY  CONDITIONS 
CMEGINZT)  = 0. 

IF  (ITOP  .NE.  0)  OMEG( NZT  ) = TOPA  • 


OMEG  ( 2)  , NZT-2,  IERR) 


SINGULAR, 21 I0,E16.8) 


OMEG(NZT  ) = TOPA  • ( TD  P 2*  OME  G ( NZT1 ) 

+TOP 1»0MEG( NZT-2 ) -TEMP  T»  EVE C 1 1 l + NZT) ) 


CMEG(l)  = 0. 
IF  ( I BOT  .NE. 


OMEG(l)  = BOTA  • ( B0T2»0MEG( 2) 

♦ BDT 1*0M  EGl 3 )-TEMP3»E VEC ( I i*l ) ) 


POMI  = INTEGRAL(PS I*OMEGA)i  POMN 1 = INTEGRAL (PS I-OMEGA*  SON) 
POMI  = 0. 

POMNI  =0.  _ „p 

SKIP  IF  TCLINE  EXTENDS  TU  SJRFACE 
IF  (ITOP  .EC.  0)  GC  TO  60 
I NTEGRAL ( PS I»OMEGA ) FROM  ZT(NZT)  TO  0. 

POMI«(  UOMEG(NZT  )/TMP-T0PB)»RK-.5/ZTN  )•  TOP  3-  . 5 ) • TMP*«  2 / ( R» 
SKIP  IF  TCLINE  EXTENDS  TO  FLOOR 
60  IF  ( I BOT  .EQ.  0)  GO  TO  70 

INTEGRAUPS  I»OMEGA ) FROM  -OCNDEP  TO  ZT(1) 

POMI*  = ZPOMIE+E( ( (OMEG( l )/TMP-B0T8)»R<  - . 5/ZT1D  )*B0T3  +.5) 

, •TMP»»2/  ( RK*ZT ID) 

QUADRATIC  INTEGRATION  FROM  ZT(1>  TO  ZT(NZT) 

70  DO  80  I- 1 , NZT 


H0P3-.5)»TMP*»2/(RK*ZTN) 


T 


on  o on 


CPOM  = QIC(  II«EVEC(  Ii  + I I«OMEG<  I I 
POMI  = POMI  ♦ QPOM 
80  POMNI  = POMNI  + QPOM  *S3N(  I I 
C SECOND  DEKIV  OF  LAMBDA  WRT  < 

90  TDLDKZ(MUCE)  = ( ( 1 .-DLD<*POMNI  I / R K +2.*P0MI)  » OLDK. 

100  CALL  T I MLR( -5 ) 

RETURN 

END 

SUBROUTINE  CTEVAL 
C Gr NERATE  c I GtNV  ALU  tS 

C 

COMMON  / CENT RL / ICASE,  ICKFLG(20),  JDISP,  JFFT,  JROT 
1,  NODISP,  N0GK1C 

EQUIVALENCE  ( MODS  E A,  IC<  FLG(l)  ) , ( MOUG BS , ICKFLG ( 2 I I 
1,  ( MODBOD,  ICKFLGl  3 I I,  ( MOUWAK  , ICKFLG  ( 4 ))  t ( MOD  S UP  , I C KF  LG  ( 5 I I 

C 

COMMON  /FILES/  NTILIB,  NTDL l B,  NTPDEF,  NTPID,  NTPU A T , NTPLOT 
1,  NTDTAB,  NTEVEC,  NTTEMP 

r 

COMMON  /OCEAN/  LIBSEA,  MOOES,  NK,  TABK(IOC),  iNZT , DKRAT,  DTDEP 
1,  TDEPMX,  TDEP(400),  NFLAG,  SQBV1400),  OCNDEP,  RKMA X 

SCN(400),  NKT,  IPPVEC 
C 

COMMON  //  RK,  ITHK,  ZT1400),  LWAVEC*  NZT1,  NZ  T 2 » ZT1D 

1,  ZTN,  ITUP,  I BOT i SQ< , TOPI,  TOP  2 » '0P3,  TGPh,  TGP7  , T0P8 

2,  uCTlt  BuT  2 • 8CT  3,  B0T4,  B0T7,  B0T8,  I ERR  » 0IC(400) 

3,  NT  ROT , Z,  Zj,  TEVAH  400),  T0LDKI6O)*  TP33S180I 

4,  TDPCBSdO),  TCPSRCI 80)  , TwK&O),  TPSUPTIbO),  TPSUPR(tO) 

5,  T CL  GK2 ( oO  I , EVfcCl 400, 60) , TEMP  l <«00, 5)  , 5JI4G0I 

6,  T R I M AT  ( 400 , 3 I , SDI400),  SDLI400),  SDL2UC0),  0H400I.  D('+00> 

7,  OU  ( -00  ) , CON  ( <,00  ) , 3ME  G(  400 ) , bN3(4G0),  IEVAL(40G) 

8,  EV3PST  ( 90  ) , PS1N2K8G) 


call  r I Mb  K ( 3 ) 

IERR  = 0 

SKIP  IF  OCEAN  FAS  BEEN  CHANGED  FROM  PREVIOUS  CASE 
IF  (MOOSEA  .NE.  0 .OR.  LIBSEA  .NE.  0)  GO  TO  20 
NO  CHANGE.  Rt  AD  ALL  DISPERSION  TABLE  DATA  (INCLUDING 
EIGENVALUES  I PERTAINING  TO  THIS  VALUE  OF  K 
I f ( I T HK  . GT . 1 I GO  T 0 3 
REWIND  NT  ROT 
READ(NTRDT)  MOOEST 

3 RE  AD ( NT  ROT  I RK  , ( T EV ALl  M ) , T CL  CK ( M I , TPOBS ( M ) , TDPOB  S ( M I , TOP  SRC ( M ) , 

1 TWI (MJ,TPSJPT(M ),  TPSUPB(M) , TDLDK2 (MI*  M=1,MOOESTI 

IF  ( EOF , N7  ROT  I 5,10 
5 IERR  * 1 
10  T ABK ( ITHKI  = RK 
GO  TO  190 
C 

C COMPUTE  EIGENVALUES.  SKIP  IF  NOT  FIRiT  PASS 

20  IF  (ITHK  .NE.  II  GO  TO  50 

C LOOP  THROUGH  POINTS  IN  TCiINE  TABLE.  NZT2=FWA-1  OF  UPPER  DIAGONAL 

00  30  1*2, NZT 1 

032  = ZT ( I+il  - ZT( I I 
031  = ZT ( I + 1 1 - ZT ( I- l I 
021  = ZT ( I I - ZT(  I - 1 ) 

C SET  UP  PARAMETER  USED  IN  COMPUTING  MATRIX  DIAGONAL 

DC ( I ) - 2 ./ ( D32*D2 1 1 

C LOWER  AND  UPPER  DIAGONALS  OF  THE  TRI-DIAGONAL  MATRIX 

TRIMAl(I)  = -2.  / ( D31*D21*SQN ( I I I 
30  TRI MAT ( I + NZT2 I = -2.  / ( D3 1* D32*SQN( I 1 1 
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C 

C 


C 

C 


C 

C 


C 

c 

c 


SAVE  CURP2NT  VALUE 


<►0 


SKIP  IF  TOP  OF  TCLINE  IS  AT  SURFACE 
IF  (ITOP  .EC.  0)  GO  TO  AO 

LOWER  DIAGONAL  ELEMENT  NZT-1  WILL  VARY  WITH  K. 

OLSAV  = TRIMAT  INZT  l ) 

NOTE  THAT  HERE  D32  = Z T ( NZ T I -ZT ( NZ T- 1 ) , D31=ZT(NZT)-ZT(NZT-2) » 
D2  i = ZT  I NZT-I ) -ZT  ( NZT-2) 

T0F1  = 032/ C 031*021) 

TO  P2  = -031/(032*021) 

Skip  if  bottom  of  tcline  is  at  floor 

IF  ( I BOT  .EC.  0)  GO  TO  50 

UPPER  OIAG  ELEMENT  (2)  WILL  VARY  WITH  <.  SAVE  GURRtNT  VALUE 
DUS  AV  * TRIMAT  (NZT  2+2) 

B0T1  = - ( ZT ( 2 ) -Z  T I 1 ) ) / ( ( ZT ( 3 ) -ZTl i ) ) • ( ZT ( 3 > - ZT ( 2 ) ) ) 

B0T2  = ( ZT ( 3 ) -ZT 1 1 ) ) / II Z T ( 3 ) -Z T I 2 ) ) * l ZT l 2 ) -Z T ( 1 ) ) ) 


COMPUTATIONS  FOR  EACH  VALUE  OF  K 
50  RK  = T A BK ( ITHK ) 

SQK  = RK*  *2 

GENtRATE  DIAGGNAL  ELEMENTS  0 F THE  TRI-DIAGONAL  MATRIX 
DO  60  I=c,NZTl 

60  TRIMAT ( I+NZT ) = (SQK+DCII))  / SONII) 


C 

C 


SKIP  IF  TCLINC  EXTENDS  TO  SJRFACE 

IF  (ITOP  .EQ.  0)  GO  TO  90 

IF  (RK  .NE.  0. ) GO  TO  70 

TAKE  LIMIT  FOR  K=0 

TOPA  = 1./ (TCP1+T0P2+1./ZTN) 

GO  TO  80 

70  TOP?  = EXP(2.*RK*ZTN) 

COTHI RK*ZTN) 

TOPS  = (TCP7  + 1.)  / ( TOP 7-1 . 1 
TOPA  = 1./ (RK*TOP8+TOP1+TOP2  ) 

RESET  NEXT-TC-LAST  ELEMENTS  OF  DIAGONAL  AND  LOWER  DIAGONAL 
80  TR I MAT ( NZT  2-1 ) = T R IMAT! NZ T2- 1 ) + TOP A* T0P2* TR I MA T ( NZT2+ NZT1 ) 
TRI MAT ( NZT 1 » = DLSAV  ♦ TOP A*TOP  1*TR IMAT ( NZT2+NZT1 ) 


C 

C 


SKIP  IF  TCLINE  EXTENDS  TO  FLOOR 
90  IF  ( IBOT  .EQ.  0 ) GO  TO  120 
IF  (RK  .NE.  0. ) GO  TO  100 
TAKE  LIMIT  FOR  K=0 
BOTA  = 1 . / ( BCT 1 + BUT  2+1 ./ZT ID) 

GO  TO  110 

100  BCT 7 = EX  P ( -2 . *RK*ZT ID ) 

B0T8  = (1.+B0T7)  / (1.-B0T7) 

BOTA  = 1 . / ( RK* BOT 8 + 60T  i.  +B0T2  ) 

RESET  ELEMENTS  OF  DIAGONAL  AND  UPPER  DIAGONAL 
ilO  TRIMAT  (NZT+2)  = T R IMAT  ! NZ  T +2  ) + B0TA*B3T2*TR  IMAT  ( 2) 
TRIMAT (NZT2+2)  * DUSAV  + BOT A*B0T1*TR  IMAT ( 2 ) 


C 

C 


SYMMETRIZE  THE  MATRIX 

120  CALL  FIGKNZT,  NZT-2,  TRIMAT12),  SD,  SDL,  SDL2,  IERR) 
IF  (IERR  .EQ.  0)  GO  TO  1A0 
WRITE(6,130)  IERR, ITHK, RK 

130  FORMAT ( 29H  ERROR  IN  SYMMETRIZING  MATR IX, 21 10, E 16. 8) 

GO  TO  190 


C 

C 

c 


SKIP  IF  EIGENVALUES  MJST  BE  COMPUTED 
1A0  IF  (MUDSEA  .NE.  0)  GO  TO  170 

READ  DISPERSION  TABLE  LIBRARY  FILE 

READ(NTOLIB)  (TEVAL(M),  I EV AL ( M ) » TDLDK 2( M ) , M = l, MODES) 
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i 


I . 
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1 


! 


— ■ 


o o o 


i 


( 


I 


IF  ( EOF, NT  DL I B ) 150,160 
150  I ERR  = 1 
GO  TO  190 

SPLIT  MATRIX  INTO  SUB-MATRICES  IF  OFF-DIAGONAL  ELEMFNTS 
ARE  NEGLIGIBLt  (REQUIRED  BY  TINVIT,  NORMALLY  JU'JE  BY  RATQR) 

pmache  is  a machine  de3endent  parameter  i=ma:bep  in  rat'jrj 

160  PMACHE  = 2. **(-47) 

SDL2 ( 1 ) = 0. 

LIM  = NZT  - 2 
DO  155  1=2, LIM 

165  IF  ( A BS  ( S DL  ( I ) ) .LE.  P M ACH  6*  ( AB  S(  SD(  I))  + Ab  S(  SJ  ( I - 1 ) ) ) ) 

1 SDL 2 ( I ) = 0. 

GO  TO  190 

C COMPUTE  THE  LOWEST  E IGENVAL J ES 

170  E PS  1 = 0, 

IOEF  = 1 

CALL  R AT  OR  ( NZ  I -2 , EPS1,  SD,  SOL,  SDL  <L , MODES,  JtVAL,  IEVAL, 

1 END,  .TRUE.,  IDEF , I ERR  ) 

IF  ( I ERR  . EC.  0 ) GO  T 0 190 
WRITE!  6,  lfaO)  IERR,  ITHK,  RK 

18  0 FORMAT ( 3 1 H ERROR  IN  COMMUTING  E I GEN  VALUE S* 21 10 , E 1 b.  8 ) 

190  CALL  T IMER! -3  ) 

RETURN 

END 

SUBROUTINE  CTtVEC 
C GENERATE  EIGENVECTORS 

C 

COMMON  /CGNTRL/  ICASE,  ICKFLG!  2C),  JDISP,  JFFT,  JPOT 
li  NODISP,  NOGRIC 

EQUIVALENCE  ( MODS  E A,  IC<  FLG  ( 1 ) ) , ( MOL’OBS,  ICKFLG  ( 2 ) ) 
li  ( MODBCC,  ICKFLG! 3 ) ),  IMOCWAK,  I C<  F_  G ( 4 ) ) , ( MODSUP , I 1 KF LG  ( 5 ) ) 

C~ 

COMMON  /FILES/  NT  I L IB,  NT0LI3,  NTPDEF,  NTPID,  NTPDAT,  NTPLOT 

1,  NTDTAL,  NT  EV  EC,  NTT  EMP 
C 

COMMON  /OCEAN/  LIBSEA,  MOOES,  NK , TABK(IOO),  NZT,  DKKAT,  DTUEP 
It  TDEPMX,  TDEPUOO),  N F _ AG,  SQBVI400),  OCNOEP,  RKMAX 

2,  S QN ( 400  ) , NKT,  IPPVFC 
C 

COMMON  //  RK,  IT  HK , ZT(400),  LWAVEC,  NZTl,  NZ  T2  * ZT1D 
It  ZTN,  ITOP,  I GOT,  SQK,  TOPI,  TDP2,  TGP3,  T0P4,  T0P7,  T0P8 

2,  BOT 1 , BGT2,  B0T3,  BOT  A , B0T7,  BCT  8,  IERR,  QIC(ACO) 

3,  NTRCT,  Z,  Z.S,  TE/AL(400),  TDLDK(BO),  TP0BSI80) 

A,  T DPCBS ( 80 ) , TOPS  R C ( 8 0 ) , TWI(80),  TPSUPT180),  TPSUPB(PO) 

5,  T DLDK2 ( 8 0 ) , EV  EC  ( 400  ,80),  TEMP(400,  5),  OK^OO) 

6,  T R I M AT  ( tOO  , 3 ) , SD(400),  SDL<400),  SDL2I400),  DLI400),  0(400) 

7,  DU  ( AGO  ) , CON  ( 400  ) , 0MEG(400),  BND1400),  IEVALI400) 

8,  EV3PST ( b 0 ) , PSIN2IieO) 

C 

C 

CALL  T I M E R ( 4 ) 

C JUMP  IF  OCEAN  HAS  BEEN  CHANGED  FROM  PREVIOUS  CASE 

IF  (MODSEA  .N£.  0 .OR.  LIBSEA  .NE.  0)  GO  TO  50 
C NO  CHANGE.  READ  ALL  EIGENVECTORS  FOR  THIS  K 

BUFFER  I M NT  EV  EC , i ) 1E/EC!  1)  , EVEC!  LWAVEC  ) ) 

C WAIT  FOR  READ  TO  BE  COMPLETED 
10  IF  (UN  I T , NT  EVEC  ) 10,  220,  20,  20 
20  WRITE(6,30  ) IT  HK  , MODES , NZT 
30  FORMAT ( 2 5 H ECF  READING  E I GEN  V EC  TOR S , 3 I 1 0 ) 

CALL  ERF.XIT 
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C 

C 

C 

C 

C 

C 


COMPJTE  EIGENVECTORS.  SKIP  IF  NOT  FIRST  PASS 
50  IF  ( I THK  .NE.  1)  GO  TO  70 

SET  UP  COEFFICIENTS  TO  3UAD*ATICLY  INTEGRATE  FUNCTIONS 

SPECIFIED  AT  POINTS  ZT  ( I) 

INTEGRATE  PARABOLA  FITTED  TO  POINTS  1-2-3,  3-4-5,  5-6-7... 

LOOP  FOR  EACH  PARABOLA 
DO  60  I = 2 , NZT 1 , 2 
D32  = ZT ( I + 1 ) - ZT ( I) 

03 1 = ZT ( 1 + 1 ) - ZT ( 1-1 ) 

D21  = ZT  ( I ) - Z i i 1-1 ) 

ClC(I-l)  = CIC(I-l)  ♦ ( 1.- .5*032/021  )*D31/3. 

CIC(I)  = C31  **3  / ( 6 • *D3  2*  D2 1 ) 

60  GICII+l)  = ( 1 .-.5»C21/032  ) »D31/3. 

: SKIP  IF  NZT  IS  ODD 

IF  ( 2 * ( NZT/ 2 ) .NE.  NZT)  GO  TO  70 
C SET  UP  COEFFS  TO  INTEGRATE  FROM  ZT(NZT-l)  TO  ZT(NZT) 

G1CINZT-2)  = UICINZT-2)  - 03 2** 3/ ( 6 . *D31«D2 1 ) 

QIC(NZTI)  = QIC(NZTl)  ♦ ( 3 .♦D32 /D 2 1 ) *032 /6. 

CIC  NZT)  = ( 2. *021/031 )*D32/6. 

COMPUTE  EIGENVECTORS  FOR  THIS  K. 

WAIT  UNTIL  FINISHED  WRITING  OLD  SET  OF  EVECTORS 
70  IF  (UNIT  , NT  EVEC)  70,  80,  80,  80 
C EIGENVECTORS  CORRESPONDING  TO  SYMMETRIC  MATRIX 

80  CALL  T I NV I T ( NZ T , NZT-2,  SD,  SDL,  SDL2,  MODES,  T£VAL»  f^VAL, 

1 EVEC( 2) , I ERR,  T EMP  ( 1,  1 ) * TEMP l 1, 2 ) , TEMP (1 ,3)  , TE MP d ,4)  , 

2 TEMP*  1,5)) 

IF  ( I ERR  .EQ.  0)  GO  TO  100 
WRI TE ( 6 ,90 ) I LRR, ITFK,  RK 

90  FORMAT ( 32H  ERROR  IN  COMPUTING  E IGEN VECTOR S , 21 1 0, E 1 6 . 8) 

C TRANSFORM  EIGENVECTORS  BACK  TO  NON- SYMME TR I C MATRIX  SYSTEM 

100  CALL  BAKVEC( NZT,  NZT-2,  TR IM  AT ( 2 ) , SDL,  MODES,  EVE- (2),  ICRR) 
IF  ( I ERR  .EQ.  0)  GO  TO  120 

HR  I TE  ( 6 » 1 10  ) I ERR,  IT  HK , RK  Mtn  LU  .. 

110  FORMAT ( 40H  ERROR  IN  BACK  TRANSFORMING  E I GEN VE- TOR S, c 1 1 0 ,E 1 6 . 8 ) 

GO  TO  220 
C 

C SKIP  IF  TOP  OF  TCLINE  IS  AT  SURFACE 

120  IF  (ITOP  .EQ.  0)  GO  TO  140 
C PARAMETER  USED  TO  INTEGRATE  FROM  ZT(NZT)  TO  SURFACE 

IF  (RK  .NE.  0. ) GO  TO  130 
C TAKE  LIMIT  FOR  K=0 

T0P3  = -ZTN/3. 

GO  TO  140 

C T 0P7 ,8  COMPUTED  IN  DTE  V AL  . TO P 7=EXP ( 2. • RK* ZTN ) 

C T0P8=C0TH(RK*ZTN) 

130  TCP3  = 2.*ZTN*T0P7/(T0P7-1.)**2  - .5*T0P8/RK 
C SKIP  IF  BOTTOM  OF  TCLINE  IS  AT  FLOOR 

140  IF  ( I BUT  .EQ.  0)  GO  TO  160 
C PARAMETER  USED  TO  INTEGRATE  FROM  FLUOR  TO  ZT(1) 

IF  (RK  .NE.  0. ) GO  TO  150 
C TAKE  LIMIT  FOR  K=0 

B0T3  = ZT1D/3. 

GO  TO  160 

B0T7 , 8 COMPUTED  IN  CTEVAL.  BO T 7=EXP ( -2 . *RK* ZT 10 ) 

B0T6  = COT  H( KK*ZT ID ) 

150  B0T3  = -2.*ZTiD*BOT7/(  1 .-B0T7)»*2  ♦ .5*B0T8/RK 


C 

C 

C 

C 


NORMALIZE  EACH  EIGENVECTOR.  I1=FWA  OF  EVECTJR,  IE  = LWA 
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160  It  = 0 

DO  210  MODE=i »MODES 
II  = IE  +1 
IE  = It  + NZT 

C P2I  IS  NORMALIZE  ION  INTEGRAL  FOR  CURKEMT  E IGfcNVEC  TOR 

P2I  = 0. 

EVEC(IE)  = 0. 

C SKIP  IF  TCLINc  EXTENDS  TO  SURFACE 

IF  ( I T Q P .EQ.  0)  GC  TO  170 

C ENFORCE  BOUNDARY  CONDITION  AT  TOP  OF  TCLINE.  TOPI, 2,** 

C ARE  SET  IN  DTtrVAL 

EVFC(IF)  = T0P4»  ( T0P1*EVEC(  IE-2  ) + TOP  2*E  VEC  ( IE-  1 ) ) 

C INTtGRAL  FROM  ZT(NZT)  TO  0. 

P2I  = TOP  3 * EVlC I I E ) **2 
C 

170  EVECI  ID  = 0 . 

C SKIP  IF  TCLINc  EXTENDS  TO  FLOOR 

IF  ( I30T  .EQ.  0)  GO  TO  ISO 

C ENFORCE  BOUNDARY  CONDITION  AT  ROTTOK  OF  TCLlNt.  R0T1,2,A  ARE 

C SET  IN  DTEVAL 

EVECdl)  = BCT4*  ( B0T1*EVEC(  1 1 + 2 ) +B3 T Z» E VLC I 11  + 1)  ) 

C ADD  IN  INTEGRAL  FROM  -OCNDEP  TO  ZTIi) 

F2I  = P2I  + B0T3*EVEC(  1 1 ) * *2 
C 

C CUADRATTC  I NT  cGR  AT  I CN  OF  EVECT0R»*2  FROM  ZTII)  TO  ZTINZT) 

C I NT  EGR AT  E ( EVECT  OR*N ) **  2 AT  SAME  TIME 

180  PN2 I = 0. 

J=  1 

DO  190  1=  11,  IE 

QPZ.  = QIC! J)*tVEC(  I)**2 

P2I  = P2I  + CP2 

PN2I  = PNZ  I + QP 2*SQN I J ) 

190  J » J*1 
C 

C NORMALIZE  AND  SAVE  I NT  EGRAL  (PSI»N>**2 
PS  I N2  I (MODE)  = PN<-  I/P2  I 

C NORMALIZE  BY  MULTIPLYING  EVECTOR  BY  ENORM 

ENORM  = 1./SQRTIP2I) 

C ATTACH  SIGN  CF  1ST  NON-ZERO  ELEMENT  OF  EIGENVECTOR  TO 

C NORMALIZATION  CONSTANT  TO  ENSURE  ALL  EIGENVECTOR  a FOR  A GIVEN 

C MODE  HAVE  THE  SAME  PARITY 

ENORM  = SIGN! ENCRM , EVECI IE ) ) 

IF  (EVECI IE)  .EQ.  0.)  ENORM  = S I GN ( ENORM, EVEC ( IE-1 ) ) 

C DO  THE  NORMALIZ  AT  ION 

DU  200  1=  II, IE 

200  EVECI I)  = ENORM»EV  EC( I ) 

210  CONTINUE 
C 

C start  WRITING  THE  EIGENVECTORS  AND  PROCEED  WITH  COMPUTATIONS 

BUFFER  OUT INTEVEC,  1)  I E VEC I 1 ) , E V EC  I L WAVEC ) ) 

C 

220  CALL  T IMERI-A) 

RETURN 

END 

SUBROUTINE  DT I NIT 

C INITIALIZATION  FOR  D.T.  COMPUTATIONS 

C 

COMMON  /EUDY/  I BODY , IPBODY,  BODDEP , BODDIA,  BODLEN,  BODSPD 
1,  RBS:P2,  RBSTR,  RBLIM 

C 

COMMON  /CGNTRL/  ICASE,  ICKFLGI20),  JDIS’,  JFFT , JPOT 
1,  NODISP,  NOGRID 
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EQUIVALENCE  (MODSEA,  ICKFLGIl)),  t MODO  BS»  ICKFLG ( 2 ) ) 

1,  { MODBOD, ICK -LG(3) ),  I MODWAK , I CK FLG <4 ) ) t ( MODSUP , I C KF LG ( 5 ) ) 

COMMON  /FILES/  NT  IL  IB»  NTDLIB,  NTPDEF,  NTPID,  NTPL)AT,  NTPLOT 
1,  NTCTAR,  NTEVEC,  NTT  CMP 

COMMON  /GRID/  OBSDEP*  V3BS,  DOBS»  33SMAX,  TAB33S(100>,  ITHOBS 

1,  X , CX,  XMIN,  NX,  IT  FIX,  Y,  DY  , YM  IN , NY,  ITHY,  MODE  1 , MODEN 

2,  IVAR,  IPRDT*  IPPDTI9),  XPMAX,  YPMA X,  1PPPSD,  I PREDG 

3,  ISPHAS 

COMMON  /OCEAN/  LIBSEA,  MODES,  NK,  TABK(IOO),  NZT,  31-RAT,  DTDEP 

1,  TDEFMX,  T DEP  ( 400  I , NFL  AG,  SQBV(400),  OCNDEP,  R.'MAX 

2,  SQN(AOO),  NKT , I’PVFC 

COMMON  //  RK , ITHK,  ZT  ! 400  ),  LWAVEC,  NZT1,  NZT2,  ZTID 

1,  ZTN,  ITbP,  I EOT,  SCK,  TOPI,  T0P2,  T0P3,  TDP4,  T0P7 , TOPB 

2,  HOT  1 , B0T2,  BOT 3 , B0T4,  B0T7,  B0T8,  IERR,  QIC (-00) 

3 f NTRDT,  Z,  ZS,  TEVALI AGO) , TDLDK180),  TP33SIB0) 

4,  TDPCBSIbO),  TDPSRCI 80) , TWI(80),  TP  SUP  T(  80) , TP  SUPB ( 80 ) 

5 f T CLCK2 ( 80  ) , EVECI 400,80),  TEMP(400,5),  DC(4C0) 

6,  TRIMAT( 400, j ),  SD(400),  SDL(VOO),  SDL2(4C0),  DL(400)»  D(400) 

7,  DU1400J,  CON ( 400 ) , 3MEG(400),  BND(400),  IEV\L(400) 

8,  EV3PST180),  PS  IN  2 I ( 60  I 


FLIP  LOGICAL  TAPE  NUMBER S--NTRDT*FILE  FRC.1  WHICH  TO  READ  DT  FROM 
PREVIOUS  CASE,  NT OT AB=  FILE  ON  WHICH  TO  WRITE  NEW  DT, 

NTTEMP=T  EMP  STORAGE  (NOT  USEC  BY  CT  MODULE) 

NTRDT  = NTUTAB 
NT  DT  AB  = NTT  EMP 
NTTEMP  = NTRCT 

EIGENVECTOR  FILE  HAS  PARALLEL  I/O.  BE  SURE  ITS  READY 
10  IF  {UNIT, NTEVEC)  10,20,20,20 
20  REWINO  NTEVEC 

30  IF  (UNIT, NTEVEC)  30,40,40,40 

SKIP  IF  OCEAN  CATA  WAS  INPUT 
40  IF  (MOOSE A .NE.  0)  GD  TO  70 

DT  LIBRARY  FILE  IS  USED  ONLY  ON  1ST  PASS  DF  1ST  CASE 
(AFTER  THAT,  UT  SAVER  FILE  IS  USED) 

IF  (ICASE  .NE.  1 .OR.  ITH3BS  .GT . 1)  GO  TD  80 
VERY  1ST  PASS.  SKIP  IF  USING  DT  LIBRARY 
IF  (LIBSEA  .NE.  0)  GD  TO  60 
WRITE(6,50) 

50  FORMAT ( 24H  NO  OCEAN  DATA  SPECIFIED) 

CALL  ERRXIT 

READ  1ST  RECORD  OF  CT  LIBRARY 
60  REWIND  NTOLIB 

READ!  NT  CL  I B ) NKT  , ( T AB<  ( I),I  = 1»NKT),NZT,(TDEP(I),I=1»NZT) 
l,  (S3N(  I)  , 1=1, NZT), OCNDEP, MODES 

GO  TO  90 

SET  UP  K LIST  AND  TCLINE  TABLE 
70  CALL  OTSETK 
CALL  DTSETN 
START  NEW  DT  LIBRARY 
REWIND  NTDLIB 

WRITE! NT DL IB)  NKT, I TAB <(  I),I  = 1,NKT),NZT,(TDEP(I)  ,1  = 1, NZT) 

1,  (SQN(I), 1=1, NZT), OCNDEP, MODES 


80  LIBSEA  = 0 
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C CONVERT  INCREASING  TCLINE  DEPTHS  TO  INCREASING  Z COORDINATE 

90  DO  100  I - 1 * NZ T 
100  ZT  ( I ) = -TDEPINZT-M1) 

C 

C ASSORTED  WIDELY  USED  VARIABLES 

NZT 1 = NZT-1 
NZT2  = NZT+NZT 

C LW  A OF  LAST  EIGENVECTOR 

LWAVEC  = NZT  *HODES 
Z1  ID  = ZT(  1)  4-  OCMDEP 
ZTN  = ZT ( NZT  ) 

Z * -OBSDER 
ZS  = -BOD'JEP 

C SET  FLAG  IT0P=0  IF  TOP  OF  TCLINE  IS  AT  SURFACE 

I T CP  = 0 

IF  (ABS iZTN/ZT (1)  ) . GT . l.E-10)  ITJP  = 1 
C SET  FLAG  1B01=0  IF  BOTTOM  OF  TCLINE  IS  AT  OCEAN  FLOOR 

I BOT  = 0 

IF  ( AOS ( ZT 1C/Z  T( 1 ) ) .GT.  l.E-10*  IBOT  = 1 

RETURN 

END 

SUBROUTINE  GTUBS 

C COMPJTE  AND  STORE  EIGENFUNCTION  AND  ITS  DERIVATIVE  AT  OB  S DEPTH 

C 

COMMON  / CONT KL / ICASE,  IC<FLC(20),  JDISP,  JFFT,  JPOT 
It  N0D1SP,  NOGRIC 

ECUIVALENCE  (MODSEA,  I C < FL  G ( 1 )),  (MODOBS, ICKFLG  (2)  ) 

It  (MOOBODt  ICKFLGI 3 ) )»  ( MODWAK , ICK FLG < 4 ) ) , ( MOD  SUP 1 1 C KF LG ( 5 )) 

C 

COP  MON  /OCEAN/  LIBSEA,  MODES,  NK,  TABK(IOC),  NZT.  DKRAT,  DTDEP 
It  TCEPMX,  TCEP(AOO),  NFlAG,  SQBVI400),  OCNOEP,  RKMAX 

2,  SCNI400),  NKT,  IPPVEC 

C 

COMMON  //  RK,  IT  HK , ZTI400),  LWAVEC,  NZTl,  NZT2,  ZT1D 
It  ZTN,  ITOP,  IBOT,  SG<,  TOPI,  TOP  2,  TUP  3 , 10P4,  T0P7 , TOPS 

2,  BGT1,  BOT  2 , B0T3,  B0T4,  B0T7,  B0T8,  I ERR , 010(400) 

3,  NT  RUT , Z,  ZS,  TEVALI400),  TDLDM80),  TP03SI80) 

A,  T DPCBS ( 30  ) , TDPSRC(SO),  TWI(bO),  TPSUPTI80),  TPSUPB(BO) 

5,  T CLCK2 ( dO  ) , FV  EC ( 400 , 80  ) , TFM?(400,5),  3C(4C0) 

6,  TRIMATUOO,  3),  SDI400),  SDU  400),  SDL2(400',  01.(400),  D(400) 

7,  UU(AOO),  CONI400),  0MEGI4C0),  8ND(400>,  IEVAL1400) 

8,  EV3PST  ( 80  ) , PS  IN  2 I ( 80 ) 

DIMENS ICN  CPI  3 ), CDP< 3) 

C 

C 

C RETURN  IF  SAME  AS  PREVIOUS  CASE 

IF  (LIBSEA  + MCCS  EA+MODOBS  . E3 . 0)  RETURN 
C GET  COEFFS  FOR  COMPUTING  P S I AND  DIPSII/DZ  AT  OBSERVATION  DEPTH 

C ON  1ST  PASS  OR  IF  Z IS  OUTSIDE  TCLINE 

IF  (ITHK  .EQ.  1)  IND  = 0 

!<=  (IND  .LE.  0)  CALL  DTPSICIZ,  IND,  CP,  COP) 

C JENERATE  PSI  FOR  EACH  MODE 

CALL  DTPSKTPOBS,  IND,  CP) 

C GENERATE  DIPSD/DZ  FOR  EACH  MODE 

CALL  DTPSI  (TCPOBS,  IND,  CDP  ) 

RETURN 

END 

SUBROUTINE  CTPSIIPSI,  IND,  COEF) 

C GENERATE  EIGENFUNCTION  (OR  ITS  DERIVATIVE) 

C 

COMMON  /OCEAN/  LIBSEA,  MOOES,  NK,  TABK.(IOO),  NZT,  OKRAT,  DTDEP 
1,  TDEPMX,  TDEP(AOO),  NFLAG,  SQBV(400),  OCNDEP,  RKMAX 
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SQNI400) 


IPPVEC 


T0P7  , 
(400) 


DU(400),  CUN ( 400  ) * OMEGl 
i,  EV2  PST  ( 80  ) , PSIN2U80) 

DIMENSION  CCEF ( 3 ) , PS  I C 1 ) 


T0P8 


TPSUPBI80) 

>0) 

DLI400) , D(400) 
L (400! 


PRESET  TO  PICK  UP  LAST  ELEMENT  OF  EVECTOR 
J = NZT 

JUMP  IF  DESIRED  DEPTH  IS  BELOW, ABO VE , IN  SIDE  TCLINfc 
IF  HMD)  10,20,40 

BELOW  TCLINE.  SET  TO  PICK  JP  1ST  ELEMENT  OF  E VECTOR 
10  J = 1 

LOOP  FOR  EACH  EVECTOR 
20  DO  30  M0CE=1, MODES 

ANALYTIC  EXPRESSION 
PSI(MOJE)  = COEF*EVEC(  J ) 

30  J = J ♦ NZT 
RETURN 

INSIDE  TCLINE.  LOOP  FOR  EACF  EVECTOR 
40  J = IND 

DO  50  MODEM,  MODES 

QUADRATIC  INTERPOLATION  ri,cr  . ...  , 

PS  I (MODE  ) = COEF(  1 )«EVEC(J-i)  + COFF I 2 )*  EVEC  C J ) ♦ COEF  (3)»EVEC  < JM  ) 

50  J = J ♦ NZT 
RETURN 
END 

SUBROUTINE  DTPSICUCES,  IND,  CP,  CDP  ) „ollJ  AT 

GENERATE  COEFFICIENTS  FOR  DETERMINING  EFUN^TION  AND  DERI  V AT 

COMMON  /OCEAN/  LIBSEA,  MODES,  NK,  TABK(IOO),  NZT,  DKRAT,  DTDEP 

1,  TDEPMX,  TDEP1400),  NFLAG,  SQBV(400),  OCNDEP,  RKMAX 

2,  S QN( 400 ) , NKT , IPPVEC 


COMMON  // 


ITHK,  ZTI  400),  LWAVEC,  NZT1,  NZT2,  ZT1D 


f ZTN,  ITOP,  I BOT , SQK,  TOPI,  T0P2,  T0P3,  T0P4,  T0P7,  T0P8 

, BOT 1 , BOT 2,  BOT  3,  BDT4,  B0T7,  B0T8,  I ERR  , QIC (400) 

lf  NTRDT,  Z,  ZS,  TE/ALI4C0),  TDLDM80),  TP0BSI80) 

h TDPQBS  ( 80  ) , T DP  S R C ( 80),  TWI180),  TPSUPT(80),  TPSUPB(80) 

i . TDLDK2180),  EVECl  400,80) , TEMP(  400,5),  DC(4C0)  nl/nni 

t,  T RIMAT  (400, 3 ),  SD(400),  SDLI400),  SDL2(400),  DH400),  0(400) 

DU (400  ) , C0N( 400 ) , 0MEG1400),  BND(400),  IEVAL(400) 

),  EV3PST (80 ) , PSIN2IOO) 

POSITION  ZDES 
DIMENSION  CPI  3 ),  CDP(3) 

SKIP  IF  DESIRED  POINT  IS  BELOW  TOP  OF  TCLINE 
IF  (ZDES  .LE.  ZTN)  GO  TO  20 

PRCTECT  FROM  LOW  ORDER  BITS  IF  TCLINE  GOES  TO  SURFACE 
IF  (ITOP  .EQ.  0)  GO  TO  20 
SET  FLAG  SHOWING  ABOVE  TCLINE 
IND  * 0 

IF  (RK  .NE.  0. ) GO  TO  10 


* > 


CP  = ZDES/ZTN 
COP  = l./ZTN 
GO  TO  70 

TMP  = EXPI  RK*<  ZTN-ZCES  ) ) / I EXP  ( 2.*  <K«Z  TNI ) - 1 . ) 

TM PI  = EXPI2.*RK*ZDES  ) 

CP  = S1NHIRK*Z0ES  )/S  INHIRK*ZTN> 

CP  = TMP*( TMP1-1 . ) 

COP  = RK*CUSHIRK*ZDES)/SINH(RK*ZTN) 

COP  = RK*TMP*(  , MP'  +1  . ) 

GO  TO  70 

SKIP  IF  OESIKuC  POINT  IS  ABOVE  BOTTOM  OF  TCLINE 

IF  (ZOES  .GE.  ZT I 1)  ) GO  TO  AO 

IF  ( I ROT  .EC.  0)  GO  TO  40 

SET  FLAG  SHOWING  BELOW  TCLINE 

IND  = -1 

IF  IRK  .NE.  0.  ) GO  TO  30 
CP  = (ZCEb-»UC\DEP)/ZTlD 
COP  = l./ZTID 
GO  TO  70 

TMP  = t'XPIRKM  ZDES-ZTI  1 )) ) / ( I .-EXP  I - 2 . *RK* Z T ID ) ) 

TMP1  = EXPI-2.  *RK*IZDES+OCNDEP  ) ) 

CP  = SINHIRK*!  ZDES  + OCNDEP  ))  / S I NH  ( RK*  Z T1D ) 

CP  = TMP*(  l.-l  MP1) 

COP  = RK*CGSH I RKMZDES+OCNDEP) I ' :iNH(RK*ZT10) 

COP  = RK*TMP*I  l.+rMPI) 

GO  TO  70 

ZOES  IS  WITHIN  THE  TCLINE 

INCOMING  VALUE  OF  IND  IS  LOWER  LIMIT  TO  SEARCH  FOR  I, 

NHERE  ZT(I-I)  .LE.  ZDES  .LE.  ZTII) 

LIM  * M AXO  I it  IND) 

00  50  I = L I M , NZT 1 

IF  (ZOES  .LE.  ZT ( 1 ) ) GO  TO  60 

1 = NZT1 

ADJUST  I SO  THAT  ZTII)  IS  CLOSEST  TABLE  POINT  TO  ZDES 
IF  I ZDES-ZT  I I - 1 ) .LT.  ZTII)-ZOES)  I = 1-1 

SAVE  POSITION  IN  TABLE.  NOTE  IND  .GT . 0 IMPLIES  WITHIN  TCLINE 
INO  * I 

CEL  = ZDES  - Z T I I - 1 ) 

DEL2  = 2.*0EL 

032  = ZT  I 1 + 1 ) - ZTII) 

D31  = ZTU+i  ) - ZT  I 1-1  ) 

D2I  = ZTII)  - ZTI  1-  1) 

COEFFS  FOR  QUADRATIC  INTERPOLATION  OF  EIGENFUNCTION  P S I 
CPU)  * 1.  ♦ CEL*<  DEL-D31-C2I  ) / 1 D3 1*  021  ) 

C P 1 2 ) = DEL*!  U3I-0EL  ) / I 03  2*  02  1 ) 

CPU)  = DEL*!  CEL-021)  / I 03  2*  0 3 1 ) 

COEFFS  FOR  INTERPOLATING  DIPSD/DZ 
COP  1 1 ) = I DEL2-D31-C21  ) / ( 021*031) 

C0PI2)  = I 03 1 -DEL  2 ) / <D32*D21) 

CDPI3)  = (0EL2-D21)  / ID32*D31) 

RETURN 

END 

SU 8R0UT I Nt  OTSETK 

SET  UP  WAVE  NUMBER  K LIST 

COMMON  /CONST/  J OK » JDMODE  * JUTCL,  PI,  NULL,  JDCKL,  JDMFT 
, JDCKSV,  JDMSP,  JDCDGE 

COMMON  /OCEAN/  L1BSEA,  MODES,  NK,  TABKI  ICO)  , NZT,  DKRAT,  DTDEP 
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,h  ..It  . ■ W ,i 


j— I 


1 


* 

'1 


\ 


( 


1,  TDEPMX,  T DEP  ( 400  ) * NFLAG,  SQBVIA00),  OCNDEP,  RKMAX 

2,  SON*  400 ) , NK  f , IPPVEC 
C 

c 

C SKIP  IF  DESIRED  SIZE  OF  K LIST  IS  WITHIN  DIMENSION 

IF  (0  .LT.  NK  .AND.  NK  .LE.  JDK)  CD  TO  20 
WHITE (0,10)  NK.JDK 

10  FORMAT ( AH  NK=,I4,23h  IS  ILLEGAL.  DIMENSI 0N=, IA ) 

CALL  ERRXIT 

C SKIP  IF  K LIST  WAS  INPJT  DHECTLY 

20  IF  ( DKRAT  .LE.  0.)  GO  TO  50 
C PRESET  FOR  ECUAL  INTER/ AL  TABLE 

C = 1. 

OEL  = RKMAX/ FLOAT ( NK-1 ) 

IF  (DKRAT  .EG.  1.)  GO  TO  30 

C GENERATE  K LIST  WITH  DELTA  < INCREASED  BY  FACTOR  C FOR  EACH  POINT 

C = DKRAT «•( 1 ./ FLOAT ( NK -2 ) ) 

DEL  = RKMAX  • (C-l.)  / (C«D<RAT-1.) 

30  TABK(l)  = 0. 

DO  AO  1=2, NK 
T ABK ( I ) = TASK ( I -1 ) ♦ DEL 
AO  DEL  = C*DEL 
C 

50  NKT  = NK 
RETURN 
END 

SUBROUTINE  DTSETN 
C SET  UP  THERMOCLINt  TABLE 

C 

COMMON  /CONST/  JOK,  JDMODE*  JDTCL , ?I,  NULL,  JDCKL,  JDMFT 
1,  JDCKSV,  JDMSP,  JDEDGE 

C 

COMMON  /OCEAN/  LIBSEA,  MODES,  NK , TABKI100),  NZT , DKRAT,  DTDEP 

1,  TDEPKX,  T DEP ( A 00 ) , NFLAG,  SQBV(AOO),  OCNDEP,  RKMAX 

2,  SQN(AOO),  NKT,  IPPVEC 
C 

C 

C SKIP  IF  DESIRED  SIZE  OF  TCLINE  TABLE  IS  ACCEPTABLE 

IF  (3  .LE.  NZT  .AND.  NZT  .LE.  JDTCL)  GO  TO  20 
WR I TE ( 6 , 10  ) NZT,  JDTCL 

10  FORMAT ( 5H  NZT=,IA,23H  IS  ILLEGAL.  DI MEN S ION  * , I A ) 

CALL  ERRXIT 

C PRESET  INTERNAL  INCREMENT  !N  TCLINE  DEPTHS 

20  DEL  = DTDEP 

C IF  IT  WAS  INPUT,  USE  IT  TO  CONSTRUCT  LIST  OF  DEPTHS 

IF  (DEL  .NE.  0.)  GO  TO  30 

C IF  MAX  DEPTH  IS  ALSO  ZERO,  LIST  WAS  INPUT  DIRECTLY 

IF  (TDEPMX  .EC.  0. ) GO  TO  50 

C COMPUTE  INCREMENT  FROM  INPUT  MAX,  MIN  AND  NUMBER  OF  POINTS 

DEL  = (TDEPMX-TDEP( 1) ) / FLOAT ( NZT-1 ) 

C CONSTRUCT  EQUAL  INCREMENT  TABLE 

30  DO  AO  1=2, NZT 
AO  TDEP(  I ) = TDEP<  1-1  ) ♦ DEL 
C 

C SET  UP  LIST  OF  N»«2(ZT  ) 

50  DO  60  1=1, NZT 

60  SQN(I)  = SQBVt NZT-I+1) 

C JUMP  IF  IT  WAS  REALLY  N*«2  INPUT  INTO  S3BV 

IF  (NFLAG  .EQ.  0)  GO  TO  80 

C IT  WAS  N ( = BRUNT  VAISALA  FREQUENCY).  CONVERT  TO  N»*2 

DO  70  1=1, NZT 

70  SQN(I)  = SQN( 1 )«»2 


r 


I 
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c 

c 


c 


c 


c 


80  RETURN 
END 

SUBROUTINE  CTSUPR  ,T11,r 

COMPUTEf  STORE  E l GEN F JN CT l ON  AT  TOP  AND  BOTTOM  OF  SUPERSTRUCTURE 


COMMON  /CONTRL/  ICASE,  IC<  FL  G ( 20),  JD1SP,  JFFT,  JP3T 
1,  NODISH,  NOGRIC 

EQUIVALENCE  ( MODS  EA , IC  < FLG  ( 1 ) ) , ( MODO  BS,  I CK  FL  G ( 2 ) ) 

1,  ( MGCHCC, ICKFLG ( 3 ) ) , (MOI'WAK,  ICKFLG(A)  ) , ( '10DSUP  , I C KF  LG  (5  ) ) 

COMMON  /OCEAN/  LIBSEA,  MOOCS,  UK,  TABK(ICC),  NZT,  OKRAT,  UTDEP 

1,  TDEHMX,  TDF.PI^OO),  NFlAG,  SQBVIhOO),  OCNUEP , RKMAX 

2,  SQN ( 400 ) , NKT,  IPPVEC 

COMMON  /SUPER/  ISUPR,  SJPTOH,  SUPBOT,  IPSUPR,  SUSTR,  SUSE  P 2 
1,  SUPM^IU,  SULIM,  SJPDIA,  SUPLEN 

COMMON  //  RK , I T H< , ZT(AOO),  LWAVEC,  NZT1,  NZT2,  ZTID 

1,  ZTN,  ITOP,  I DOT  , SQK , T3P1,  T0P2,  T0P3,  T3PA,  T0P7,  T0P8 

2,  BOTx,  BUT  2 , BOT  3 , BO  T A , B0T7,  3GT8,  I ERR  , QIC(AOO) 

3,  NTKDT,  Z,  ZS,  TEVAL(ACO),  TGLUK ( 90 ) » TPuBS(80) 

A,  TDPOBS(jO),  rOPSRCUO),  TWHSO),  TPSUPT(BO),  TP  SUP3  (20) 

5,  T DLUK2 (SO),  EV  EC  ( AOO  , 8 0 ) , TEMP(A00,5),  DC(ACO) 

6,  TRIM  AT  (t  00, 5),  SQ(AOC),  SDL(AOO),  SDL2(^00),  DL(*+00),  D(AOG) 

7,  OU(AOO),  CON(AOO),  OMEGIAOO),  BND(ACO),  lEVAL(ACO) 

8,  EV3  RST ( 90 ) , PSIN2K80) 

DI  MENS  ION  CPT(  3)  , CPBI3),  DJMMYI3) 


C 

C 

c RETURN  IF  SAME  AS  PREVIOUS  CASF 

IF  (LI BSEA+MCCSEA+MCDS JP  . EQ  . 0)  RtTURN 
C GENERATE  CUEFFS  FOR  COMPUTING  PSI  AT  TOP  AND  BOTTOM  OF  LINE 

C SOURCE/SINK  CN  1ST  PASS  OR  IF  OUTSIDE  OF  TCLINE 

IF  (IT  HK  « NE . 1 ) GO  T 0 10 
INDT  = 0 

10  I F0^ I NOT  .LE.  0)  CALL  DT P SI C ( Z S + SUPTUP , INDT,  CPT,  DUMMY) 

IF  ( I NDB  .LE.  0)  CALL  DTP S I C ( l S+S UPBOT,  INDB,  CPB,  DUMMY) 

C GENERATE  PSI  FOR  ALL  MODES  AT  TOP  AND  BOTTOM  OF  SUPERSTRUCTURE 

CALL  DTPS  KTP3UPT,  INOT,  CPT) 

CALL  DTPSI  (TP^UPB,  INOB,  CPB) 

RETURN 

END 

SUBROUTINE  DTWAKE 
C EVALUATE  WAKE  INTEGRAL 

COMMON  /BODY/  IBODY,  IPBODY,  ROODEP,  BODDIA,  BODLEN,  BODSPD 

1,  R0SEP2,  RBSTR,  RBLIM 

C 

COMMON  /const/  jok,  jdmooe,  jdtcl,  pi,  null,  jdckl,  jdmft 

l,  JDCKSV,  JDMbP,  JDEDGE 


COMMON  /CCNTRL/  ICASE,  ICKFLG(20),  JDI5P,  JFFT,  JPOT 
1,  NODISP,  NOGRIC 

EQUIVALENCE  ( MODS  EA, ICKFLG( l)  ) , (MODOBS, ICKFLG(2)  ) 

1,  1 MODBOC,  ICKFLG( 3 ) ),  ( MODWAK  , ICKFLG ( A) ) , ( MODSUP , I C KF LG ( 5 ) ) 


COMMON  /OCEAN/  LIBSEA,  MODES,  NK,  TABK(IOO),  NZT,  OKRAT,  DTDEP 

1,  TDEPMX,  TDEP(AOO),  NFLAG,  SQBV(AOO),  OCNDtP,  RKMAX 

2,  SQN(AOO),  NKT,  IPPVEC 


COMMON  /WAKE/  IWAKE,  CWAKR,  CWAKX,  XWAKE,  WAKRAO,  XWNOM 
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RESLVS.  CWAKM 


C 

c 

c 


c 

c 


c 

c 


c 

c 

c 

c 

c 


c 

c 


c 

c 

c 

c 

c 


1. 

2, 

3, 

4, 

5, 
6 , 
7 , 
8, 


COMMON  //  RK,  ITHK,  ZT(400),  LWAVEC,  NZT1,  NZT2.  ZT1D 

ZTN#  ITGP,  I BOT , SQK • TOPl»  TOP?.  TOP  3 » TQP4,  TOP7 . TOP3 
BCT1.  BLT2,  BDT  3 » B0T4,  BOT7,  B0T8,  IERR,  0 1 - C A-OOJ 
NTROT,  Z.  ZS,  TEVAU4C0),  TDLOK  ( 80 ) , TPOB  S ( 80  ) 

TDPCBS(ttO),  T OPS  RC(  80 ) , TWII80),  TPSUPT(80),  TPSUPB(BO) 
TDLOK2(bO),  EV EC(  400 , 80  ) , TEMP ( 400, 5)  , DC ( 400) 

T R1MAT  ( <.00.  3 ) . SD(400),  SDK  400),  S0L2(4C0),  DLI400),  D(400l 
DU1400),  CON  ( 400  ) • OMEG(  400  ) . BN0(4C0),  IEVAK400) 

EV3  PST  (30  ) • PSIN2K80) 

DIMENSION  COEF  ( 3 ) » DUM  M Y ( 3 ) 


C 

c 


RETURN  IF  NC  CHANGE  FROM  PREVIOUS  CASE 
IF  ( L I BS EA+MODSE A+MOOW A<  . E3 . 0)  RETURN 
CALL  T I ME  R ( 6 ) 

SKIP  IF  NOT  FIRST  PASS 
IF  (ITHK  .NE.  1)  GO  TO  40 
JUMP  IF  SUB  IS  INSIDE  TCLINE 

IF  ( Z T ( 1 ) .LT.  ZS  .AND.  ZS  .LT.  ZTN ) GO  TO  10 

5 FORMAT  (49H  EPROR--WAKE  RECUESTED  BUT  BODY  IS  OUTSIDE  TCLINE) 

CALL  ERRXIT 

FIND  111,112  SUCH  THAT  ZT(IU)  .LT.  ZS  .LT.  ZY II  1 2 ) 

10  DO  15  112=2, NZT 

15  IF  (ZT(II2)  .GT.  ZS)  GO  TO  20 
NEVER  FALL  THROUGH  ABOVE  LOOP 
20  III  = 1 12-1 

IF  ( ZT  (III)  .GE.  ZS)  III  - IU-1 

FRGUOE  NUMBER  BASEO  ON  N AVERAGED  OVER  BODY  DIAMETER 
NOTE  DTAVcN  IS  A FUNCTION  FOR  AVERAGE  N 
FD  = 2.*PI*BOCSPD/(OTAVEN( BOCDIA)»BODDIA ) 

WAKE  RADIUS  FROM  THAT  FROUCE  NUMBER 
WRAD  = . 5 *CW  AK  R*  BOCDI A*  FD*  * • 25 
AVERAGE  N OVER  W AK  E RADIUS  JUST  COMPUTED 
BV  = DTAVEN(  2.  *WRAD) 

FROUOE  NUMBER 

FD  = 2.  *PI*BOOSPO/( BV*BODO  IA  ) 

WA'vRAD  = .5  *CW  AK  R*  BOCD I A*  F D*  * .25 

NOMINAL  START  OF  WAKE  COLLAPSE  (DDES  NOT  INCLUDE  SIZING 

FACTOR  CWAKX) 

XWNOM  = FD*BUUO  I A 
AVESQN  = 3V**2 

COMPUTE  INTEGRAL  OF  AV ESCN *( Z +BODDEP ) *S I N ( E T A* SQRT l WAKRAD**2 
-( Z+BODOEP) **2 ) )*PSI/ETA*DZ  FROM  -BODDEP-WAKRAD  TO  -80DDEP+ WAKRAD 

LOOP  FOR  EACH  MOCE 
40  DO  190  M0DE=1, MOOES 

FWA-1  OF  EV  ECTOR 
LOCI  = ( MOOE-1 ) *NZ  T 
COS (THET  A) **2  = (XI/RK)**2 
C2T  = 1./ (TEVAL(MOOE)*BODSPD**2) 

SKIP  IF  SPEED  IS  SUB-CRITICAL 
TW I ( MODE)  = 0. 

IF  (C2T  .GT.  1.)  GO  TO  190 
ET  A=RK*SIN(THET  A) 

ET A = RK*SQRT ( 1.  -C2T) 

INTEGRANO,  DISPLACEMENT  AT  SUB  DEPTH, 

G * 0. 


INITIAL  VALU:  OF  INTEGRAL 
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no  non  on  noon  on  ooooo  non  non 


ZET  PST  = 0. 

SUMI  = 0. 

C ARGUMENT  OF  SIN  FJNCT  ION  IN  INTEGRAND 

SARG  = W AKR  AC*  ET  A 

C DISPLACEMENTS  GF  rCLINE  TABLE  POINTS  BELOW  ANJ  ABOVE  SUB  DEPTH 

zru  = zs  - zriiin 

ZLT2  =-ZS  + Z1  ( I 12  ) 

C SET  INDICES  OF  NEXT  TCL  INE  POINTS  FROM  INITIAL  VALUES 

11  = III 

12  = I 12 

C INPUT  RESOLUTION  GIVES  MAX  ALLOWED  INCREMENT  IN  SARG 

DSARG  = PI/RESLVS 


5 0 


START  INTEGRATION  LOOP 

SAVE  PAST  VALUE  OF  INTEGRAND  AND  TENTAT 
GPST  = G 

SARG  = SARG  - DSARG 


VELY  Sc  T NEW  SARG 
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IF  (SARG  .GT.  0.)  GO  T 
SINE  RESOLUTION  PERMITS 
THIS  ) . T ENT  AT  IVELY  SET 
ZET  = WAKRAL) 

SARG  = 0. 

GO  TO  70 

SET  DISPLACEMENT  CORRES 
ZET  = S CRT ( W AKR AD**2  - 


0 60 

STEP  TO  END  OF  INTERVAL  (K  = 0 ALWAYS  DOES 
DISPLACEMENT  TO  ENO-OE - I N TE R VA L 


PONCING  TO  THIS  VALUE  OF  SARG 
( SARG/ETA)**£) 


HIT 

AL 

POINTS 

IN  TCL  I N 

E 

T ABL 

E 

IF 

(ZET 

• LT  . Z ET  1 ) GO 

TO 

80 

HIT 

POINT  AT  Z ET 1 UNLESS 

Z ET  2 

OCCURS 

FIR 

ST 

IF 

( ZET2 

.LT.  Z 

ETl)  GO 

TO  90 

ZET 

1 IS 

FIRST. 

HIT  IT 

AND  PO 

INT  TO  N 

EXT 

ENTRY 

ZET 

= ZET1 

11 

= 11 

- 1 

SLT 

Z ET  1 

FOR  TH 

IS  NEXT 

ENI RY  . 

PRESET 

TO 

END  OF 

WE 

WENT 

OFF  THE 

TABLE. 

ZET 

1 = W 

AKRAC 

IF 

(11  . 

GT.  0) 

ZET  1 = 

ZS 

- Z 

Till) 

IF 

Z ET  2 

MATCHED 

ZET1,  F 

IX 

IT 

TOO 

IF 

(ZET  2 

- ZET) 

110,  100, 

1 10 

JUMP  IF  SINE  RESOLUTION  IS  CONTROL!  !NG  CRITER1UN 
80  IF  (ZET  -IT.  ZET2)  GO  TO  120 

ENTRY  AT  12  GIVES  SMALLEST  STEP.  USE  ZET2 
90  ZET  = Z ET 2 

POINT  TO  NEXT  ENTRY. 

100  12  = 1 2 ♦ 1 

SET  CORRESPONDING  ZET 2 (SET  TO  WAKE  RADIUS  IF  ABOVE  TCLINE) 
ZET2  = WAKRAC 

IF  (12  .L£.  NZT ) ZET2  = ZT(I2)  - ZS 
RESET  SARG  SO  IT  CORRESPONDS  TO  THE  NEW  ZET 
110  SARG  = ET A«SQRT(WAKRAD**2  - ZET**2) 


PICK  UP  Z COORDINATES  CORRESPONDING  TO  DISPLACEMENT  ZET 
1.20  Z1  = ZS  - ZET 
Z2  = ZS  + ZET 

GET  COEFFS  FOR  DETERMINING  E FUNCT I ON  AT  Z1 
J1  = II  ♦ 1 

CALL  DTPSICIZ1,  Jl,  COEF,  DJMMY  ) 

C COMPOTE  EFUNCTION  AT  Zl.  NOTE  Z1  NEVER  ABOVE  TCLINE 

IF  (Jl  . GE . 0)  GU  TO  130 
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c 


i 


■ i 


■ 


| 

t 


, 


c 


c 


c 


c 

c 


c 

c 

c 

c 

c 


Z1  BELOW  TCLINE 

UNZ1  = CGEF*EV  EC ( LOC  l*  1 ) 

GO  TO  140 
Z1  WITHIN  TCLINE 
130  LOC  = LOCI  + J 1 

UNZ1  = COEFI  l)«EVtC(LGC-l)  + CO EF ( 2 ) • EVEC ( LOC ) 
l + C0EF<3)*E\ZEC(LDC-H  ) 

GET  COEFFS  FOR  DETERMINING  EFUNCTION  AT  Z2 
140  J2  = 12  -1 

CALL  DTPSICU2,  J2,  COEF,  DUMMY) 

COMPUTE  EFUNCTION  AT  Z2.  NOTE  Z2  NEVER  BELOW  TCLINE 
IF  (J2  .NE.  0)  GO  TO  150 
UNZ2  = COEF«EVEC(LOCl  + NZT  ) 

GO  TO  160 
Z2  WITHIN  TCLINE 
150  LOC  = LGC1  + J 2 

UNZ2  = COEFI  1)  *EVEC(  i.OC-1)  ♦ CO EF ( 2 )* E VE C ( LOC ) 

1 + C0EF(3)*EVEC(L0C+1) 

160  IF  (RK  .NE.  0.)  GO  TO  170 
INTEGRAND  FOG  K=0 

G = (UNZ2-UNZ1 ) *ZET*SQRT(W AK R AD«*2-Z ET«* 2 ) 

GO  TO  180 

INTEGRAND  FOR  K NUN-ZERO 
170  G = (UNZ2  -UNZ 1 ) *Z  ET  «S INI SARG)/ETA 

ADD  CURRENT  STEP  INTO  INTEGRAL  (TRAPEZOIDAL) 

180  SUMI  = SUMI  ♦ .5  *(  G ♦GPST)*(ZET  -ZETPST) 

SAVE  VALUE  FOR  NEXT  STEP 

ZETPST  = ZET 

JUMP  BACK  FOP.  NEXT  STEP 

IF  (ZET  .LT.  WAKRAD)  GO  TO  50 


C 

C 


C 

C 


C 


C 


C 


ADD  WAKE  TERM  TO  DISPERSION  TABLES 
TW I ( MODE ) = AV  ESQN*SUM I 
190  CONTINUE 

CALL  T IMERI-6) 

RETURN 

END 

SUBROUTINE  DTWRIT 

SAVE  DISP  TABLE,  GENERATE  NEW  DT  LIBRARY  IF  DCE AN  CHANGED 

COMMON  /CCNTRL/  ICASE,  ICKFLG(20),  JDISP,  JFfT,  JPOT 
1,  NCDISP,  NOGRIC 

EQUIVALENCE  (MODSEA,  I C < FL  G ( 1 ) ) * ( MODOBS , ICKFL3 ( ? ) ) 
l,  (MODBOC, ICKFLG( 3 ) ),  I MODWAK, I CKFLGI 4 ) ) , ( MODSUP , IC KF LG (5 ) ) 

COMMON  /FILES/  NTILIB,  NTDLIB,  NTPDEF , NTPID,  NTPDAT,  NTPLOT 
It  NT  DT  AB,  NTEVEC,  NTTFMP 

COMMON  /OCEAN/  LIBSEA,  MODES , NK,  TABK(lOO),  NZT,  OKRAT,  DTDEP 

1,  TDEPMX,  TDEP(AOO),  N FL  AG,  SQBVI400),  OCNDEP,  RKMAX 

2,  S QN ( 400 ) , NK  T,  IPPVEC 

COMMON  //  RK,  ITHK,  ZT(4C0),  LWAVEC,  NZT1,  NZT2 , ZT1D 

1,  ZTN,  4T0P,  I HOT , SQK  , TOPI,  TDP  2,  T0P3,  T0P4,  T0P7,  T0P8 

2,  BOT 1 , BUT2,  B0T3,  B0T4,  B0T7,  B0T8,  I ERR  , QICUOO) 

3,  NTRDT,  Z,  ZS,  TEVAU  400),  TDLDK  ( 80) , TP0BS(80) 

4,  TDPOBS(BO),  TDPSRC(UO),  TWK80),  TPSUPTI60),  TPSUPB(80) 

5,  TDLDK2I80),  EV  EC  ( 400, 8 0 ) , TEMP(400,5),  DC(400) 

6,  T R I MAT ( 400, 3 ) , SD(400),  SDL(400),  SDL2I400),  DL(400),  D(400) 

7,  DUUOO),  CON  ( 400  ) , 0MEG(400),  BND(4C0),  IEVAU400) 


97 


fl 


1 | 


i ] 


4 


ooooooononoooooooooo 


8,  EV3PST180),  PS  IN  2 I { 3 0) 

C 

c 

C SKIP  IF  NCT  1ST  P »SS 

IF  ( IT  HK  . G1  . 1 ) GO  TD  5 
C INITIALIZE  0 IS  PCRS  ION  TABLE  FILL 

REWIND  NTDTaB 
WRITE!  NTDT  Afi)  MUCES 
C DISP  TAB  FGF  THIS  VALJE  OF  < 

^ WkITcl  NTDTAB)  RK  , ( T £V  Al  ( M ) , T CL  D<  ( M ) , TPD  3 S(  M ) , T jPCB  S ( M ) , TOP  SRC  I M)  , 
1 T W I ( M ) , T P SUP  T(M), TPS UP b(M),TDLD<2(M),M=l, MODES) 

C JUMP  IF  OCEAN  IS  S ARE  AS  PREVIOUS  CASE 

IF  (MODStA  .EU.  0)  GO  TO  10 
C WRITE  NEW  UCE AN  ON  CT  LIBRARY  FILE 

WRITE!  NT  ULM)  (TEVAL(M),IEVAL(M),TDlDK2(M),M  = 1 .MODE  S) 

10  RETURN 
END 

SUBRUUTINc  TT  CON 

C FOURIER  TRANSFORM  AND  POTENTIAL  SOLUTION  CONTRuL 

C 

COMMON  /BODY/  IBOOY,  I P BODY , RODDER,  BODDIA,  300LEN,  bODSPD 
I,  RES  l P2 , RBSTR,  RbLIM 

C 

COMMON  / CC  NT  RL  / ICASE,  I CK  FL  G ( 20  ' JDISP,  JFFT,  JPOT 
1,  NODISP,  NOGRID 

EQUIVALENCE  (MOCSlA,  IC<FLG!  1 ) ),  ( MODOB S,  ICKFLG ( 2 ) > 

1,  (MOD  BCD,  ICKFLGI3)  ),  ( MOOWAK,  ICKFLG!  A)  ) , ( MOD  SUP  , I C KF  l.G  ( 5 ) ) 

C 

COMMON  /GRID/  OBSOEP,  NOBS,  DOBS,  QbSMAX,  TABLJB  S ( 1 00)  , I THObS 

1,  X,  OX,  XMIN,  NX,  IT  HX,  Y,  DY , YMIN,  NY,  ITHY,  MOOE1,  MQOEN 

2,  I V A K , IPRDT,  IPPDTI9),  XPMAX,  YPMAX,  IPPPSD,  IPREDG 

3,  IS  PH  AS 
C 

COMMON  /SUPER/  ISJPK,  SJPTOP,  SUPBOl,  IPSUPR,  SUS1R,  S USE  P 2 
1,  SUPMIU,  SULIM,  SJPDIA,  SUPLEN 

C 

CUM MON  /WAKE/  IwAKE,  CWAKR,  CWAKX,  XWAKE  , WAKrAO,  XWNOM 
l,  RtSLVS,  CWAKM 


••••summary  OF  APPROACH**** 

TUTAL  SIGNAL  S IGTUT  = ST + SP  WHERE  ST  IS  THE  WAVE-LIKE  SIGNAL  AND  SP 
IS  THE  PUTfeNTIAL  SOLUTION.  ST  IS  THE  INVERSE  FOURIER  TRANSFORM 
CF  T.  THIS  OPERATION  IS  DONE  IN  ROUTINE  FTFFT.  SP  IS  COMPUTED 
AND  ADDED  TO  ST  BY  ROJTINE  FTPOT. 

IN  GENERAL,  T = SUMDV  ERMODESU  P*  EXP  ( I*X  I*X  ) + TM*t  XP  (-1  * XI  »Xi  ) wHERE 
I = SQR  T { - 1 ) AND  T P=  T 1 ( X I ) AND  TM=Tl(-XI).  HOWEVER  IF 
T1  «-XI ) = CCNJG( T1 !X I ) ) v R T 1! -XI  )=-CONJG( Tl(XI) ),  THE  TOTAL 
TRANSFORM  CAN  BE  WRITTEN  T = S UM 0 VERM ODE S l 2*R E AL ( TI « E XP ( I * XI  * X )) ) 

CR  T = SU MOV ERM ODES ( 2«  I*  A IM  AG!  T 1*  EXP ( I * X I * X ) ) ) . ROUTINc  FTNEWX 
DOES  THIS  OPERATION  RASED  ON  T 1 =SUMOVERSOURCES ( TF ) WHERE 
TF  IS  THE  MODE  BY  MODE  1 RANS  FORM  (EXCLUDING  X DEPENDENCE)  DUE  TO 
A PARTICULAR  SOURCE.  THFSE  TRANSFORMS  ARE  GENERATED  BY  ROUTINE 
FTGENO.  SPECIFICALLY,  TF=V*S  wHERE  V DEPENDS  ONLY  ON  THE 
VARIABLE  (SIGNAL)  BEING  COMPUTED  AND  S DEPENDS  ONLY  OG  THE  SOURCE 
MODEL.  V IS  COMPUTED  IN  FTV AR  AND  S IS  CUMPUIED  IN  FTSRC. 


CALL  T I ME R ( 7 ) 

C SKIP  IF  NCT  1ST  PASS 

IF  (IT  HOBS  .NE.  I)  GO  TO  5 

C CCJMPJTE  BODY  SGJRCE  PARAMETERS  IF  BODY  MODEL  USED 
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IF  ( IHODYMPBODY  .NE.  0)  CALL  BODY  1 
SUPERSTRUCTURE  SOURCE  PARAMETERS 
IF  ( ISUPR+IPSUPR  .NE.  0)  CALL  SUPfU 

WAKE  SOURCE  PARAMETERS.  NOTE  1 STATEMENT  SUBROUTINES 

START  OF  WAKE  COLL  APS  E = INPUT  MUL T IPL  I ER*NQM I NA L START 

IF  (IWAKE  .NE.  0)  XWA<E  = CWAKX*XWNOM 

SKIP  IF  (WAVE-LIKE)  TRANSFORM  SOLUTION  NOT  RtUUESTEO 

IF  IJFFT  .EQ.  0)  GO  TD  10 

READ  IN  DISPERSION  TABLE 

CALL  FT  DT  A 8 

PRINT/PLOT  DISPERSION  TABLE  ON  1ST  PASS 
IF  (ITHOBS  .EU.  1)  CALL  FTDTPP 
GENERATE  TRANSFORMS  TF  FOR  EACH  SDURCE 
CALL  FTGENO 

DISPLAY  POWER  SPECTRAL  DENSITIES  ON  1ST  PASS 

IF  (ITHOBS  .EU.  1)  CALL  FTPSDS 

SKIP  IF  NO  SIGNALS  ARE  TO  BE  COMPUTED 

IF  (NX  .LE.  0)  GO  TO  AO 

LOOP  FOR  EACH  CROSS-CUT  OF  DATA 

DO  30  I THX= 1, NX 

DOWN-STREAM  COORDINATE 

X = XMIN  + CX»FLOAT(  ITHX-1 ) 

SKIP  IF  TRANSFORM  SOLUTION  NOT  REQUESTED 
IF  (JFFT  .EQ.  0)  GO  TD  20 


ARE  DUMB. 
(SEE  DTWAKE) 


COMPUTE  TOTAL  TRANSFORM  T AT 
CALL  FTNEWX 

DO  INVERSE  TRANSFORM  FOR  SIGN 
CALL  FTFFT 

ADD  IN  POTENTIAL  SOLUTION  IF 

IF  ( JPOT  .NE.  0)  CALL  FTPOT 

SEND  CROSS-CUT  DATA  TO  OUTPUT 

CALL  FTCUTS 

CONTINUE 

CALL  T I ME R ( -7 ) 

RETURN 

END 

SUBROUTINE  FTCUTS 

OUTPUT  SIGNAL  DATA  TO  PP  PROC 


FOR  S IGNAL  VALUES 


REQUESTED 


PROCESSOR 


PROCESSOR 


COMMON  /GRID/  OBSOEP,  NOBS, 
X,  DX,  XMIN,  NX,  ITHX, 


DOBS,  03.'  AX, 
Y,  DY,  YMIN , 


TABOBS(IOO),  ITN08S 
NY,  ITHY,  MODE  1 , MODEN 


IVAR,  IPRDT, 
ISPHAS 


I PP  DT  ( 9 ) , XPMAX,  YPMAX,  IPPPSD,  I PREDG 


COMMON  /NAME/  NAMES(2,10),  DTNAMS(2,9) 

COMMON  / PPCOM/ 

LENPP,  PNAME , PMIN,  PMAX,  PLEM,  VNAME , VMIN,  VMAX 
! , VLEN,  FN AME ( 2 ) , FM IN , FMAX,  FLEN,  FTODP , T I TLE ( 2 ) 

t,  IOCUR,  IPLTYP,  I PLOT , IPRINT,  I EDI  T,  NP,  IVLIST,  NOPP 

r,  I DPP , NV,  ISYM 

ENUPP,  I BLOKS  ( 1 ) 


COMPLFX  VAR 

COMMON  //  ETA,  DETA,  IETA,  NETA,  MODE,  MINMOD,  MAXMOD,  XI 

1,  RK,  DLDK , PSIO,  DPSIO,  DPSIB,  WAKI,  SUPT,  MAXK,  LOCDT 

2,  LOCCT  1(40),  IFWADT,  LHADT,  IXTRAP,  VAR,  IVSYM,  IBSYM 

3,  IWSYM,  ISSYM,  LOCDTK , JTRAN 
COMPLEX  CFFT,  CTEMP1,  C FT,  CExD 

COMMON  //  CFFT  ( 256 ) , CTEMP  1(256),  CFT(256,40),  :EXD(256,A0) 
EQUIVALENCE  (YS PACE, CFFT ) 

01  MENS ICN  YS PACE( 1 ) 
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JUMP  IF  THE  GKID  HAS  MULTIPLE  DEPTHS  AT  CONSTANT  X 
IF  (NOBS  . G1 . 1 ) GO  TO  30 

GRID  IS  MULIIPLE  X AND  CONSTANT  DEPTH 
SKIP  IF  NOT  1ST  PASS 
IF  ( IT  HX  .GT.  1)  GO  TO  10 
INITIALIZE  PP  SPECIFICATIONS 

GALL  SET IU(4HCUT S,  0,  1HX,  1HY,  NAME S ( 1 , 1 VAR ) ) 
WRITE  DATA  RECORD  FOR  THIS  X 
CALL  WRTCAT(1,  NY,  YSPACE,  1,  X) 

SKIP  IF  NOT  LAST  PASS 

IF  ( ITHX  .LT  . NX  ) GO  TO  20 

VMIN  = 0. 

VM AX  = CY*FLOAT(  NY-1 ) 

CALL  W RT 1 0 ( NY , 0,0  ) 

RETURN 


Y-Z  SCAN 

30  IF  (ITHCBS  .GT.  1)  GO  TO  AO 
1ST  PASS.  INITIALIZE  PP  SPECS 

CALL  SET IU( AHCUTS,  0,  5HDEPTF,  1HY , N AME S ( 1 , I VAR ) ) 

MAKE  FJNCTION  POSITIVE  TO  THE  LEFT 
FT  OOP  = -FTODP 

WRITE  DATA  RECORD  FOR  THIS  DEPTH 
AO  CALL  WRTDATtl,  NY,  YSPACE,  1,  OBSDEP) 

SKIP  IF  NOT  LAST  PASS 
IF  (ITHOBS  .LT.  NOBS)  GO  TO  50 
VMIN  = 0. 

VM AX  = DY  *FLCAT ( NY-1 ) 

CALL  WP.TIUNY,  0,0) 

50  RETURN 
END 

SUBROUTINE  FTDISP 

INTERPOLATE  IN  DISPERSION  TABLES  AT  GIVEN  VALUE  OF  ETA 

COMMON  /BODY/  I BODY , IPBODY,  BODDEP , BDDDI A , 3QDLEN,  BODSPD 
1,  RBSEP2,  RBSTR,  RBLIM 

COMMON  /SUPER/  ISUPR,  SUPTOP,  S'JPBOT,  IPSUPR,  SUSTR,  SUSEPZ 
1,  SUPMID,  SULIM,  SJPDIA,  SUPLEN 

COMMON  /WAKE/  IWAKE,  CWAKR,  CWAKX,  XWAXE,  WAKRAO,  XWNQM 
1,  RESLVS,  CWAKM 

COMPLEX  VAR 

COMMON  //  ETA,  DETA,  IETA,  NETA,  MODE,  MINMOD,  MA  <MOD , XI 

1,  RK,  DLDK,  PSIO,  DPSIO,  DPSIB,  WAKI,  SUPT,  MAXK , LOCDT 

2,  LOCOTl(AO),  IFWADT,  LWADT,  IXTRAP,  VAR,  IVSYM,  IBSYM 

3,  IWSYM,  ISSYM,  LOC  DTK , JTRAN 
COMPLEX  CFTBOU,  CFTSUP,  CFTWAK 

COMMON  //  CFT  G00(  256  ) , CFTSUP  ( 256  ) , C FTWAK  ( 256  ) , TAB X I C 2 5 1;  > 

1,  TKO(AO),  TK(IOO),  TETA  ( 100, AO) , TOLDK (100, AO)  , TPSI 0 ( 1 00 , AO ) 

2,  TDPS 1 0 ( 100, AO),  T DPS  IB  ( 100, AO) , TWAKI ( 100, AO) , TSUPT ( 1 00 , AO ) 

EQUIVALENCE  ( T EMP 1, CFT BOD) 

01  MENS  I ON  TEMP  1(9,  1) 


FIND  PROPER  POSITION  H OISP  TABLE. 

DC  10  I--  LCJCCT  , L W ACT 

IF  (ETA  .LE.  TETA(  I)  ) GO  TO  20 


ASSUME  ETA  ALWAYS  INCREASES 
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C FLAG  THAT  ARGUMENT  EXCEEDS  TABLE  RANGE 

I XT  RAP  = 1 
RETURN 
C 

C LINEAR  INTERP  TO  FINC  K AS  FUNCTION  OF  ETA 

20  C2  = ( ET  A-TET  A(  I-I  ) ) / ( TE TA < I )- TF T A ( I - 1 ) ) 

Cl  = 1.-C2 

C K INDEX  WHICH  CORRESPONDS  TO  I 

J = I-LCCCTK 
TEMP  = TK(J-l) 

C IF  T ET  A ( I -1 ) =0  * PICK  JP  K FROM  1ST  POINT  LIST 

IF  (1-1  .£Q.  IFWAOT)  TEMP  = TK.  0(  MODE  ) 

RK  = Cl *T EMP  + C2  *TK ( J ) 

C LINEAR  INTERP  TO  FIND  REMAINING  VARIABLES  AS  FUNCTION  OF  K 

C D(  LAMBDA)  / UK  WHERt  LAMBDA  = 1/C**2 

DLDK  = Cl *T  DLDK ( I — 1 ) ♦ C2*TDL0K(I) 

C NORMALIZED  EIGENFUNCTION  PSI  AND  D(PSI)/DZ  AT  OBSERVATION  DEPTH 

PSIO  = Cl  *T  PS  I 0(  i-  1 ) + C2*T?SI0(I) 

CPSIO  = Cl *T  DPS  101  I — 1 > + C 2*  TOP  S 10 ( I ) 

C D ( ° S I ) / D Z AT  BODY  DEPTH 

IF  ( I BODY  .NE.  0)  CPSIB  = C 1* T DP S I B ( I - 1 ) + C2*TDPSIB(I) 

C WAKE  SOURCE  TERM 

IF  (IWAKE  .NE.  0)  W A<  I = C1*TW  A<  I ( I-  1 ) ♦ C2»TwAKl(I) 

C SUPERSTRUCTURE  TERM  = PS  1 1 BOTTOM  OF  SUPER)  - PSI  (TOP  OF  SUPER) 

IF  ( ISUPR  .NE.  0)  SUPT  = Cl «T SUPT I I — 1 ) ♦ C2*TSUPT(I) 

C SAVE  CJRRENT  (ABLE  POSITION  FOR  NEXT  ENTRY 

LOCDT  = I 
RETURN 
END 

SUBROUTINE  FTDTAB 

C READ  DISPERSION  TABLE  AND  PERFORM  FINAL  ADJUSTMENTS  DN  IT 

C 

CUMMON  /BLDY/  IBUDY,  IPBODY,  BODDEP,  BDDDIA,  BUDLEN,  BODSPD 

1,  RBSEP2,  RBSTR,  RBLIM 

C 

COMMON  /CONST/  JDK,  JDMODE,  JDTCL » PI,  NULL,  JDCKL , JDMFT 
It  JCCKSV,  JDMSP,  JDEDGE 

C 

COMMON  /FILES/  NTILIB,  NTDLIB,  NTPDEF,  NTPID,  NTPDAT,  NTPLOT 
1,  NTOTAB,  NT  EVEC»  NTT  EMP 

C 

COMMON  /GRID/  OBSDEP,  NOBS,  DOBS,  OBSMAX,  TABOBS(IOO),  I THOBS 

X,  UX,  XMIN,  NX,  ITHX-  Y,  DY,  YM I N , NY,  ITHY,  MO0E1,  MODEM 
I VAR , IPRDT,  I PP  DT ( 9 ) , XPMAX,  YPMAX,  IPPPSD,  I PREDG 
I S PH  AS 
C 

COMMON  /SUPER/  ISJPR,  SJPTOP,  SUPBOT,  IPSUPR,  SUSTR , SUSEP2 
1,  SUPMIO,  SULIM,  SJPOIA,  SUPLEN 

C 

COMMON  /WAKE/  IWAKE,  CWAKR,  CWAKX,  XWAKE  , WAMAD,  XWNOM 
1,  RESLVS,  CWAKM 

C 

COMPLEX  VAR 

COMMON  //  ETA,  DET  A,  I ETA,  NETA,  MODE,  MINMOO,  MAXMOD,  XI 

1,  RK,  DLDK,  PSIO,  DPSIO,  DPSIB,  WA<I,  SUPT,  MAXK,  LOCDT 

2,  LOCDT 1 ( 40 ) , IFWADT,  LWADT,  IXTRAP,  VAR,  IVSYM,  I B SYM 

3,  IWSYM,  ISSYM,  LOCDTK , JTRAN 

COMPLEX  CFT  900,  CFTSUP,  CFTWAK 

COMMON  //  CFT  BOD( 256 ) , CFTSJPI2E6),  CFTWAK(256),  TA3XI(256) 

1,  T KO { 40 ) , TK(IOO),  TETA( 100, 40 ) , TDLDK ( 100, 40) , T P SI  0 ( 1 00 , 40 ) 

2,  TDPSIOI 100,40),  TOPS  I B { 100,40) , TWAKI ( 100, 40) , TSUPT(100,40) 
EOUIVALFNCE  IT  EMP  l,  CFT&3D) 
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CALL  T I ME  R ( 6 ) 

SQUIN  = l./B0USPD**2 

C MODEl  AND  MODEN  ARE  INPJT  LIMITS  OF  DESIRED  MODES.  SC  T UP 

C INTERNAL  STORAGE  ANC  DO-LOOP  LIMITS  TO  SQUEEZE  OUT  UNUSED  MODES 

MINMOO  = 1 

MAXMOD  = MODLN  -MOUE1  +1 

C CHECK  MODE  RANGE  AGAINST  AVAILABLE  STORAGE 

IF  (MAXMOC  . L E . JDMFD  GO  TO  6 
HR  I TE ( 6 *3 ) MODEl, MOCEN,JDMFT 
3 FORMAT  I 29H  MODE  RANGE  EXCEEDS  D 1M EN S I ON , 31 1 0 ) 

CALL  ERRXIT 

C INITIALIZE  FWA  OF  TABLE  FOR  EACH  MODE 

6 DO  10  KOO£=MI NMOD, MAXMOD 
10  LOCDT 1 ( MODE  I = 0 

C DISPERSION  TABLE  IS  ON  TAPE  NTDTAB 

REWIND  NTDTAB  i 

READ(NTDTAB)  MODES 

C SKIP  IF  DISP  TABLE  HAS  AT  LEAST  AS  MANY  MODES  AS  WANTCD 

IF  (MODEN  .LE.  MODES)  GO  TO  16 
WRITE (6,131  MODEN, MODES 
13  FORMAT ( 20H  MODEN  EXCEEDS  MODES, 2110) 

CALL  ERRXIT 

C LOOP  FOR  EACH  ENTRY  (VALUE  OF  K)  IN  DISP  TAB,  BUT  DONT  EXCEED 

C STORAGE  CIMENS  ION 

16  DO  50  I K= 1 * JDK 

C READ  K, ( LAMBDA(M), DLDK(  M ),PSIO(  M ),DPSI 0(M) ,DPSIB (M)  , 

C WAKI  (M),SUPT(M),SUPB(M  ),0LDK2(M  ),M«l, MODES) 

RE  AD  (NTDTAB)  RK,  ( ( T EMP 1 ( I,  M ) , I = 1,  *3 ) , M =1 , MODE  S ) 

C SKIP  OUT  OF  LOOP  WHFN  ENTIRE  TABLE  HAS  BEEN  RL AD 

IF  (EOF, NTDTAB)  60,20 
C DATA  WAS  READ.  SAVE  VALUE  OF  K 

20  TK ( IK)  = RK 

DO  40  MODE=MI NMUU, MAXMOD 

C NOTE  THAT  HERE  ( ANO  EVERYWHERE  ELSE  IN  THE  FT  ROUTINES),  THE 

C VARIABLE  -MODE-  IS  THE  STORAGE  INDEX  OF  THE  MODE  BEING 

C CONSIDERED.  NOW  SET  ACTUAL  MODE  NUMBER 
MN  = MODE  ♦ MOD El  -l 

C TRANSFER  VARIABLES  FROM  TEMP  STORAGE  TO  DISPERSION  TABLE 
TDLDK(  I K,  MODE  ) = TEMP1(2,MN) 

T PS  I 0( IK, MOC E ) = T EMP1  ( 3,  MN ) 

TOPS  I 0 ( I K , MODE ) = TEMP1(4,MN) 

TDPSIB( IK, MODE ) = 0. 

IF  ( I BODY  .NE.  0)  T DPS  I B(  K , MODE  ) = TEMP1(5,MN) 

C SUPEPSTRUCTURE  TERM  IS  PS  I ( BOTTOM  I -P  S I ( TOP  ) 

TSUPT ( IK , MODE ) = 0. 

IF  (ISJPR  .NE.  0)  TSJP  T( IK, MODE ) = TEMP1(8,MN)  -TEMPi(?,MN) 

C SET  UP  TO  COMPUTE  ETA 

TEMP  = 1.  - SCU  IN/ TEMPI!  1,  MN  ) 

IF  (TEMP  .GE.  0. ) GO  TO  30 

C CANT  DO  IT.  SET  L OC  OF  LAST  ENTRY  FOR  WHICH  t TA  IS  IMAGINARY 

LOCDT i ( MODE ) = IK 
C SAVE  LAMBDA 

TET  A(  IK , MuOE  ) = TEMP1(1,MN) 

GO  TO  40 

30  ETA  = RK»S QRT ( T EMP ) 

TET  A(  I K,  MCDE  ) = ETA 

C FINISH  THE  COMPUTATION  OF  THE  WAKE  SOURCE  TERM  AND  STORE  IT 

TWAKI( IK, MODEl  = 0. 

IF  (IWAKE  .NE.  0)  T W A < I ( IK, MODE  ) = 2 .*CWAKM*BOD  SPD*  TE  MP1  ( 1 ,MN) 
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40  CONTINUE 
50  CONTINUE 


•TEMPI! 6, MN) 


IK  * JDK  + 1 

SET  NUMBER  OF  ENTRIES  IN  TABLE 
60  MAXK  * IK  -1 


NOW  GO  BACK  IN  THE  TABLE  AND  SET  THE  fc TA  =0  VALUES  FOR  EACH  MODE 
MODE  = MAX  MOD 
START  LOOP  FOR  EACH  MODE 
70  IKO  = LOCDT  H MODE ) 

IF  IIKO  .LT.  MAXK-I)  GO  TO  90 

TOO  FEW  TABLE  POINTS  FOR  THIS  MODE.  ALSO  SKIP  LOWER  MODES — 
THEY  ARE  WORSE  CASES 
MINMOD  = MOCE  + 1 

IF  IMINMOC  .LE.  MAXMOD)  GO  TO  13C 
WRITE(6,80) 

80  FORMAT  ( 3 1H  MAXIK)  IN  DISP  TABLE  TOO  SMALL) 

CALL  ERRXIT 


THIS  MODE. 


TABLE 


IMAGINARY  ETA  FOR  THIS  MODE 
.NE.  0.)  GO  TO  110 
CANCE ) . POINT  TO  THAT  ENTRY 


90  IF  (IKO  .GT.  0)  GO  TO  100 

NO  IMAGINARY  ETA  FOR  THIS  MODE.  SET  FWA  OF  TABLE  AND 
CORRESPONDING  K 
LOCDT 1 ( MOCE ) = 1 
TKO ( MODE ) = TK ( 1 ) 

GO  TO  120 

IKO  IS  INDEX  OF  LAST  IMAGINARY  ETA  FOR  THIS  MODE 
100  IF  (TET  A(  IKO  + ltMOOE)  .NE.  0.)  GO  TO  110 

1ST  REAL  E T A=0  (BY  CHANCE).  POINT  TO  THAT  PNTRY 
LOCDT 1 ( MODE ) = IKO  *1 
TKO ( MODE ) = TKCIKO+1) 

GO  TO  120 

AVOID  REPEATEC  INDEXING 
110  T1  = TK( IKO  ) 

T2  = T K ( IKO*  1 ) 

BACK  OJT  LAMBDA  FROM  1ST  REAL  ETA 

RL  = SQUIN/  (1  .-(  TETA(  IKO+1, MODE  )/T2)«*2) 

LINEARLY  INTERPOLATE  TO  FIND  K C L AMB DA =S3 Ul N ) 

NOTE  THAT  T ET A ( I KO, MOD E ) WAS  USED  TO  SAVE  LAMBDA 

TKO  ( MODE)  = T 1 ♦(  T2-T  1)  / ( RL-TETA(  IKOf  MODE  ) )•  ( S3UI  N-TFTA  (I  KO,  MODE  ) ) 

LINEAR  INTERP  COEFFICIENTS  FOR  POINT  AT  K=TK  OC MODE ) 

C2  = ( TKO ( MODE ) -T 1 ) / (T2-T1) 

Cl  = 1.-C2 

REPLACE  VALUES  AT  IKO  WITH  THE  ETA  =0  ( < = TKO)  VALUES 
TDLDK( I KO , MODE ) = C1*T DLDK ( IKO,  MODE ) ♦ C 2*TDLDK( I K0*1 ,MODE ) 

TPSIO( IKO, MODE  ) = C1»TP S 13 ( IK 0,MODE ) ♦ C 2« TP  SI  0 C I KO+1 , MODE ) 
TDPSIO( IKO, MOCE)  = C1*T  DPS  IOC IKO, MODE  ) ♦ C 2* TDP S I 0 ( I KO* 1 ,MODE ) 

IF  (IBOCY  .NE.  0)  TOPS  IB(  KO, MODE ) = 

1 C1*TDPSIB(  I<0,M0DE)  ♦ C 2*TDP SI  B ( I K0*1  ,MODE  ) 


IF  ( ISUPR  . NE.  0)  TSJPTC  IKO,  *ODE  ) = 

1 C1*TSUPT( IKO, MODE)  + C2*TSUPT( IK 0*1, MOLE! 

THERE  IS  NO  VALUE  OF  WAKE  TERM  AT  UO  SO  EXTRAPOLATE  FR1M 
POINTS  IKO+1  AND  IK0+2 

IF  (IWAKE  .NE.  0)  TWA<  I< IKO, MODE ) = TWAKI CIK0+1  ,M03E ) ♦ 

1 CTWAKIC IK0*2,M0DE)-TWAKIC  IKO  + 1,  MODE))  ✓ C TK  C I K0*2  ) - i 2) 

2 • ( T KO ( MOC  E ) -T  2 ) 

TET  A(  I KO  , MODE  ) = 0. 


120  MODE  = MODE-1 
IF  ! MODE  .GE. 


MINMOC)  GO  TO 


mm 


o o o 


W 


i 

l 


C 

C 


C 


C 

C 


C 


C 


C 


130  CALL  T IMER ( -8  ) 

RETURN 

END 

SUBROUTINt  FTDTPP 
PRINT/PLOT  D I $ P ; RS I ON  TABLE 

COMMOn  /BODY/  IBOOY,  1 P BODY , BODDEP,  80DDIA,  BUOLEN,  BOOSPO 
1,  RBS  l P2  i RBSTR,  RBLIM 

COMMON  /GRID/  OBSCEP,  NOBS,  COBS,  OBSMAX,  r ABUB S ( 1 CO ) , ITUOBS 

1,  X,  OX,  XMIN,  NX,  I T MX , Y,  DY,  YMIN,  NY,  ITHY,  MU0E1,  RODEN 

2,  IVAk,  IPTDT,  I PPDT  ( 9 ),  XPMAX,  Y P M A X » IPPPSD,  IPREOS 

3,  ISPHAS 

CORRON  /NAME/  NAMtS(2,  10),  DTNAMS(2,9) 

CORRGN  /PPCOM/ 

1 LENPP,  PNAME,  PMIN,  PMAX,  PLEN,  VNAME,  VMIN,  VMAX 

2,  VLlN,  FN  AME(  2 ) , FM  IN  , FM  AX,  FLEN,  F TODP  , TI  TLE  1 4 ) 

3,  ICCUR,  IPLTYP,  I PLOT , [PRINT,  ItDIT,  NP , IVLIST,  NOPP 

A,  IUPP,  NV  , 1 5 YM 

E,  ENUFP,  I BLOKS ( 1 ) 

CORRON  /SUPlR/  ISJPR,  SJPTOP,  SUPBOT,  iPSUPR,  SUSTR,  SUSEP2 
i,  SUPRIID,  SULIM,  SJPUIA,  SUPLEN 

CORRON  / r»  AK  E/  IWAK6,  CWAKR,  CWAKX,  XWA<E,  WAKRAO,  XWNOM 
It  RlSLVS,  Cwakm 

COMPLEX  VAR 

CURMON  //  ETA,  DETA,  I ET A,  NETA,  MODE,  MINMOD,  RAXMOD,  XI 

1,  RK,  OLDK,  PS10,  DPS  1 0,  CPSlB,  WA<I,  SUP  I , MAXK,  LOCDT 

2,  LOCDT 1 ( tO ) , IFWADT , LWADT,  IXTRAP,  VAR,  IVSYM,  IBSYM 

3,  IWSYR,  ISSYM,  LOCDTK , JTRAN 

COMPLEX  CFTBOD,  CFTSUP,  CFTwAK 

COMMON//  CFT  GOD(  256  ),  CFTSJP(256),  CFTWAKI 25b > , TA3Xl(256> 

1,  TK0(40),  TK(IOO),  TETA(  100, AO),  TDLDK ( 100 , AO ) , TPS  I 0 ( 1 00 , AO ) 

2,  TOPS IC( 100, AO) , TOPS  IB ( 100, 40  ) , TWAK I ( 100, AC)  , T SUP T ( 1 00 , AO ) 
EQUIVALENCE  ( T EMP 1 , CFT  BOD ) 

C I MENS  I CN  TLRPK9,  1) 

DATA  DTNAMS/5HDL/DK, 1H  , 6HW(0BS),IH  , 1 OHD W/D Z ( OB S ) , 1H  , 

1 10HCW/D2I  BOD ),  IF  , 5PTWAKE,1H  , 5HTSUPR,1H  , 

2 6HLAMBDA,  1H  , 7HD21/DK2,1H  , 4H-Y/X.1H  / 


SKIP  IF  SPECIAL  PR  INT  IS  OFF 
IF  ( IPRUT  .EQ.  0 ) GO  T 0 100 

c l:cp  for  each  mode  in  table 

DO  90  MOD E = M I NMOD , MAX  M 0D 

c actual  roce  number 

MN  = RIODE  +M0UE1  -1 
WRlTE(fc,50)  MN 

50  FORMAT ( 22H1  DISPERSION  RELATICN/7H  MODE , I 3/ 1H0 , 6 X , 1HK , 1 1 X , 

1 3HE T A,  10X , 5HCL/D<, 8X ,6FW ( OBS  ) , 7X, 23HDW/DZIOBS ) DW/DZIBOD), 

2 3X,8HTWAKE,8X,5HTSUPR) 

C FWA  OF  TABLE  FOR  THIS  MODE 

LIM  = LOCDT 1 ( MODE ) 

WRITE (6,60  ) LI M,TK0( MODE),  TETAI L IM, MODE  ) ,TDLDK( LIM, MODE)  , 

1 T PS  I 0( LIM, MODE), TOPS  10  (L  IM , MODE  ) , TDP S I B I LI M , MUO E ) , 

2 TWAK  I ( L IM,  MODE  ),TSJPT(  LIM,  MODE) 

LIM  = LIM  ♦ 1 

WRITE! 6,60  ) ( I , T K ( I ) , T ET A<  I,  MODE ) , TDLDKI  I .MODE ) , TPS  1 0 ( I .MODE ) , 
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V V 


I 


) 


J 


O O O O O 


c 

C 


EG. 

A 

.AND. 

I BODY ♦ IPBODY 

EC. 

5 

.AND. 

IWAKE  .EQ.  C) 

EQ. 

6 

.AND. 

I S UP  R ♦ I PSUPR 

1 TOPS I0(  I » MODE ) » TDPS  IB ( I , MODE ) , TWAKI ( I , MODE ) , 

2 rSUPTI  I, MODE), I=LIM,MAX<  ) 

60  FORMAT (IX,  13,8613.5) 

90  CONTINUE 

LOOP  FOR  EACH  C.T.  VARIABLE  WHICH  CAN  3E  SENT  TO  PP  PROCESSOR 
100  DO  180  ITHVAR=l,t 

SKIP  IF  PP  OPTION  IS  OFF  FOR  THIS  VARIABLE 

IF  ( I PPDTI  IT HV AR  ) . EQ . 0)  GO  TO  180 

SKIP  IF  DESIRED  VARIABLE  HAS  NOT  BEEN  COMPUTED 

.tQ.  0)  GO  TO  180 
GO  TJ  18C 

.EQ.  0)  GO  TO  180 

PRESET  THE  PP  SPECS 

CALL  SETILIDTNAMSI  1,  ITHVAR  ),  1,  4HM0DE,  3HE  TA  , D TNAM  S ( 1 , 1 TH  VA  R)  ) 

INDICATE  VARIABLE  LIST  IS  DIFFERENT  FOR  EACH  PARAMETER  VALUE 

IVLIST  = 3 

LOOP  FOR  EACH  MODE 

DO  170  MCDE=M INMOD, MAXMOO 

FLOAT  ACTUAL  MODE  NUMBER 

RMODE  = MODE  ♦ M0DE1  -1 

TWA  OF  TABLE,  NUMBER  OF  VARIABLE,  FUNCTION  PAIRS  TO  BE  WRITTEN 
II  - LOCDTl(MGDE) 

. = MAXK  -11  +1 

JUMP  UN  VARIABLE  TO  BE  DISPLAYED 
GO  TO  (110, 120, 130,1 AO, 150,160), ITHVAR 
110  CALL  WRTD3(N,  T ET  A(1 1,  MODE  ),  T DL  DK  ( I 1 , MODE  ) , 


RMODE ) 


TPS  1 0 ( I 1 ,M3DE ) , 


*■  , 


RMODE ) 


RMODE) 
RMODE ) 


GO  TO  170 

120  CALL  WRTD3(N,  T ET A ( 1 1 , MODE ) , 

GO  TO  170 

130  CALL  WRTD3(N,  T ET  A(  I 1,  MODE  ),  T DP  S 10  ( I 1,  MODE  ) , 1,  RMODE) 

GO  TO  170 

1A0  CALL  WRT D3 ( N , TET A( I 1, MODE  ),  TOP S I B I I 1 , MODE ) , 1, 

GO  TO  170 

150  CALL  WRTD3  ( N,  T ET  A(  1 1,  MODE  ),  TWAK  I ( I 1 .MODE  ) , 

GO  TO  170 

160  CALL  WRTD3(N,  T ET A ( 1 1 , MODE ) , T SUPT ( 1 1 ,MODt ) , 1.  RMODE) 

170  CONTINUE 

WRITE  THE  PP  ID  RECORD 
CALL  W RT I C ( N , 0,0) 

180  CONTINUE 
RETURN 
END 

SUBROUTINE  FT  F FT 

COMMON  /CONST/  JDK,  JDMODE,  JDTCL,  PI,  NULL,  JDCKL,  JDMFT 

1,  JDCKSV,  JDMSP,  JOEDGE 

COMPLEX  VAR 

COMMON  //  ETA,  CETA,  IETA,  NETA,  MODE,  MINMOD,  MAXMOD,  XI 

RK»  OLDK,  PS  10,  DPS  1 0,  DPSIB,  WAKI,  SUPT,  MAXK,  LOCDT 

2,  LCCCTKAO),  IFWADT,  LWADT,  IXTRAP,  VAR,  IVSYM,  I3SYM 

3,  IWSYM,  ISSYM,  LOCOTK,  JTRAN 
COMPLEX  CFFT,  CTEMP1,  CFT,  CEXD 

COMMON  //  CFFT  ( 256  ) , CTEMP  1(256  ),  CFT(25o,40),  CEXD(256,40) 
EQUIVALENCE  (YSPACE, CFFT ) 

DI MENS  I UN  YSPACE(  1 ) 

GIVEN  COMPLEX  FUNCTION  CFFT,  COMPUTE  INVERSE  FOURIER 
TRANSFORMS/ ( 2 »P  I ) * I NT EGR AL ( C F FT* EXP ( I • ETA* Y ) *DE TA ) WITH 
LIMITS  MINUS  TO  PLUS  INFINITY  AND  I=SQRT(-1). 

DISCRETE  EQUIVALENT  IS 

RESULT ( J)  = DETA/( 2*PI ) * SUM OV ER < ( CFF T ( K ) » EXP ( I * ( J - 1 ) * ( K-l ) / ( 2 *N) ) > 
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WHERE  K LIMITS  ARE  I TO  2*N,  INOEX  J=1,...,2*N  AND 
OET A*DY  = 2 «P  1/ ( 2*N ) . NOTE  EQUIVALENCE  IS  EXACT  WHEN  RESULT 

AND  CFFT  AKt  AL I AS  EC . TO  ALIAS,  ASSUME  CFFT  IS  HLRMITIAN 
SYMMETRIC  AND  UNALIASED  CFFT(J)=0  FOR  J=N+1,...  , 2*  N 


RETURN  IF  NC  SOURCES  ARE  ON  ( FFT=0) 

IF  (JTRAN  .EQ.  0)  RETJRN 
CALL  TIMER!  II) 

COEF  = GET  A/ ( 2 • »P  I ) 

HERMITEAN  SYMMETRY  REQUIRES  IM  ( CF  FT  ( 1 ) ) =0 
CFFT ( 1 ) = CMPLX ( CUEF»R  E AL  ( CF  FT ( I ) > » 0.) 

ALIASING  DOES  NOT  SPECIFY  RE ( CFFT ( N* I ) ) . MAKE  ASSUMPTION 
CFFTINETA+I)  = (0.,  0.) 

SET  INDEX  FOR  ALIASING 
I AL  = NET  A+NET  A 

JTRAN,  1=1 NPUT  CFFT  IS  REAL,  2=  IMAG IN ARY , 3=CUMPLEX 
GO  TO  < 10,30,50), JTRAN 

INPUT  CFFT  IS  REAL.  SPECIAL  IZ  I THE  CUMPLEX  CASE  FOR  SPEED 
10  DO  20  IET  A=2, NET  A 

CFFT(IETA)  = CMPLX (COEF*KEAL (CFFT(  IETA) ) , 0.) 

CF  FT ( I AL)  = CFFT!  IETA) 

20  I AL  = 1AL-1 

FLAG  TRANSFORM  AS  BEING  REAL 
I FORM  * 0 
GO  TO  70 

INPUT  CFFT  IS  IMAGINARY.  SAME  AS  CUMPLEX  CASE  tXCEPT  MULTIPLY 
BY  -SQRT(-I)  BECAJSE  FOJRT  OPERATES  FASTER  ON  REAL  DATA 
30  DO  AO  I ET  A=  2, NET  A 

TEMP  = COEF*AIMAG( CFFTI  IETA)  ) 

CFFT  ( I F.T  A ) = CMPLX  ( -TEMP,  0.) 

CFFTI 1 AL ) = CMPLX! TEMP,  0.) 

AO  I AL  = I AL- I 

FLAG  TRANSFORM  AS  BEjNG  REAL 
IF  CRM  = 0 
GO  TO  70 

INPUT  CFFT  IS  COMPLEX 
50  DO  60  I ET  A=2»  NET  A 

CFFT (IETA)  = COEF*CFFT ( IETA) 

CFFT(IAL)  = CUNJG!  CFFT!  IETA)  ) 

60  I AL  * IAL-I 

flag  transform  as  being  complex 

IFORM  = I 

70  CALL  FOURTICFFT,  NETA+NETA,  1,  1,  IFORM,  C) 


: 


so 


90 

100 

110 


RESULT  IS  ALWAYS  REAL.  AVOID  COMPLEX  NOTATION 
IF  (JTRAN  .EQ.  2)  GO  TO  90 
DO  80  I=I,NETA 
YS  PACE ( I ) = REAL! CFFT!  I ) ) 

GO  TO  110 

TRANSFORM  WAS  MULTIPLIED  BY  -SORT!-.)  SO  TAKE  I M (RE  SULT) 

DO  100  1=1 , NET  A 

VS  PACE! I ) = A IMAG! CFFT!  I ) ) 

CALL  TIMER(-ll ) 

RETURN 

END 

SUBROUTINE  FTGENO 

GENERATE  TRANSFORM  TF  FOR  EACH  MODE  AND  SOURCE 


COMMON  /BODY/  I BODY , IPBODY,  BODDEP,  BODD 1 A , BUOLEN,  BODSPD 
It  RBSEP2,  RBSTR,  RBLIM 
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COMMON  /CONST/  JDK,  JDMDUE » JOTCL*  PI,  NULL,  JDCKL , JDMF  T 
It  JOCKS  V , JOMSP,  JDEOGE 

COMMON  /GRID/  08SDEP,  NOBS,  DOBS,  ObSMAX,  TABD3S1100),  I HOBS 
1»  *t  CX,  XMIN,  NX,  ITHX,  Y,  DY,  YMIN,  NY,  ITHY,  MODE  1 , MODEN 

2»  IYAP,  IPRDT,  I PPOT { 0 i , XPMAX,  YPMAX,  IPPPSD,  I PREDG 

3,  IS  PH  AS 

COMMON  / SUPtR/  ISUPR,  SUPTOP,  SUPBOT,  IPSUPR,  SUSTR,  SUSEP? 

I»  SUPMIC,  SULIM,  SJPDIA,  SUPLEN 

COMMON  / W AKL/  IWAKE,  CdAKR,  CWAKX,  XWAKE,  WAKR4D,  XWNUM 

1,  RESLVS,  CWAKM 

COMPLEX  VAR 

COMMON  //  El  A,  DETA,  I ETA,  NETA,  MODE,  MINMOU,  M4XMOD,  XI 
It  P.K,  OLDK , PSIQ,  DPS  1 0,  DPSIB,  WAKI,  SUPT,  MAXK , LOCDT 

2,  LGCDTK40),  IFWADT,  LwAOT,  IXTRAP,  VAR,  IVSYM,  IBSYM 

3,  IWSYM,  ISSYM,  LOCDTK,  JTRAN 
COMPLEX  CFTBOC,  CFTSUP,  CFTWAK 

COMMON  //  CFT BOO { 256 ) , CFT SJP(  256 ) , CFTWAK1256),  1 A B X I (256) 

1,  TKO i 40  ) , TK(IOO),  T ETA ( ICO, 40  ) , TDLDKI 100,40)  , 1 PS  I 0 1 1 00 ,40 ) 

2,  T OPS  10 ( 100,40),  TOPS IB( 100, 40) , TWAK I ( 1 00, 40)  , TSUP T ( 1 00 , 40  I 

EQUIVALENCE  ( T CMP! , CFT BOO) 

DI  MENS  ION  T EMP  1 { 9 , 1 ) 


CALL  T I ME  R ( 9 ) 

NUMBER  OF  POINTS  IN  TRANSFORM  = NUMBER  DF  SIGNAL  POINTS 
NETA  = NY 

LENGTH  OF  ALIASED  TRANSFORM  = 2»NETA , FIND  DETA  FROM 
RELATION  DET 4*DY=2«PI/< 2*NETA ) 

DETA  * P I / ( F LU AT { N ET A ) * OY ) 

LCOP  FOR  EACH  MODE 

DO  50  MODE=M I NMQD, M AX  M DD 

ADDRESS-1  OF  K = 0 ENTRY  IN  DISP  TABLE  FDR  THIS  MODE 
LOCDTK  = ( MODE-1 ) * JDK 

ADDRESS  OF  ET A=0  ENTRY  IN  DISP  TABLE  FOR  THIS  MODE 
IFWADT  = LOCDTK  + LOCDT  UMODE) 

initialize  current  position 

LOCDT  = IFWADT 

LW A OF  THIS  MODE  IN  DISP  TABLE 
LWADT  = LUCDTK  ♦ MAXK 

PRESET  TO  ET A-W ITHIN-T ABLE . CAN  NOT  FALL  OFF  FRONT,  ONLY  END 
IXTRAP  = 0 

LOOP  FOR  EACH  ET  A 
DO  30  I ET  A=  2, NET  A 
ETA  = DETA*FLOAT(  IETA-1  ) 

INTERPOLATE  IN  DISPERSION  TABLES  USING  ETA  AS  ARGUMENT 

CALL  FTDISP 

SKIP  IF  W ITHIN  T ABLE 

IF  (IXTRAP  .EQ.  0)  GO  TO  20 

FELL  OFF  END.  ZERO  OUT  REMAINDER  OF  TRANSFORM 
DO  10  I = I ET  A,  NET  A 
TABXI ( I ) = 0 . 

CFTBODl  I ) = <0.,0.) 

CFTSUP { I ) = (0  . ,0.  ) 

10  CFT WAK ( I ) = (0  .,0.  ) 

GO  TO  40 

20  XI  = S QRT ( RK*»2  -ETA»*2) 
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TABXIIIETA)  = XI 

C COMPUTE  V WHICH  DEPENDS  ONLY  ON  THE  UUTPUT  SI  UNA  L VARIABLE 

CALL  FTVAK 

C INCLUDE  SOURCE  FACTOR! S)  ANU  SiUKb 

CALL  FTSRC 
30  CONTINUE 
C 

C EQUATIONS  BLOW  FOR  ET  A = 0 . EXTRAPOLATE  FOR  THAT  °OINT 

40  IF  ( I BODY  .NE.  0)  CFrBOC(l)  = 2.*CFTB0DI2)  - CFT8DD<3> 

IF  {IWAKE  .NE.  0)  CFTWAKll)  = 2.*CFTWAK!2)  - CF  TWA  K f3 ) 

IF  (ISUPR  .NE.  0)  CFTSUPI  1)  = 2.*CFTSUP(2)  - C F T SUP  ( 3 ) 

C WRITE  TRANSFORMS  ON  FILE 

50  CALL  FT  WRIT 
CALL  TIMER!-1?) 

RETURN 

END 

SUBROUTINE  FTnEWX 

C GENERATE  TRANSFORM  FOR  CURRENT  VALUt  OF  X 

C 

COMMON  /BODY/  IBOOY,  IPBODY,  60DDEP,  BDDDIA,  BUDLEN,  BODSPD 
It  RBSEP2,  RBSTR,  RBLIM 

C 

COMMON  /FILES/  NTILIB,  NTDLIB,  NTPDEF , M TP  ID*  NTPDAT,  NTPLQT 
It  NTDTAB,  NTEVEC,  NTTEMP 

C 

COMMON  /GRID/  OBSDE'P,  NOBS,  DOBS,  OBSMAX,  TABQbSUOO),  1 TH08S 
It  X,  CX,  XMIN,  NX, • ITHX,  Y,  DY , YMIN,  NY,  ITHY,  MODEL,  MODEN 

2,  IVAR,  IPRDT,  IPPDTI9),  XPMAX,  YPMAX,  IPPDSD,  IPREDG 

3,  ISPHAS 
C 

COMMON  /SUPER/  ISUPR,  SJPTOP,  SUPBDT,  IPSUPR,  SUSTR , SUSEP' 

It  SUPMIO,  SULIM,  SUPDIA,  SUPLEN 

C 

COMMON  /WAKE/  IWAKE,  CWAKR,  CWAKX,  XWAKE  , WAKRAD,  XWNOM 
It  RESLVS,  CWAKM 

C 

COMPLEX  VAR 

COMMON  //  ETA,  DETA,  I ET  A,  NETA,  MODE,  MINMOU,  MAXMUD,  XI 
It  RK,  DLDK,  PSIO,  DPSIO,  DPSIB,  WAKI,  SUPT,  MAXK,  LOCDT 

2,  LOCOTIUO),  IFWADT,  LWADT,  IXTRAP,  VAR,  IVSYM,  IBSYM 

3,  IWSYM,  ISSYM,  LOCDTK , JTRAN 

COMPLEX  CFFT , CTEMP1,  CFT,  CEXD 

COMMON  //  CFFT  ( 256  ) > CT  EMP  1!  256  ),  CFT«256,4C),  :EXD!256,40) 
EQUIVALENCE  l YSPACE, CFFT  ) 

DIMENS  ION  YSPACE!  1 ) 

DIMENSION  I 0! 4 ) , ISYM(4),  ISIA1I4) 

C 

C 

CALL  T IMERl 10) 

C IS--  1 = X1,  2 = BODY , 3=W  AKE,  4 = SUPERSTRUCTURE 

C I ST  AT ( IS) 1 = T URN  ON  SOURCE  IS,  0=IS  IS  OFF,  1 = I S ALREADY  ON 

C CN  1ST  PASS,  INITIALIZE  ALL  SOURCES  TO  OFF 

IF  IITHX  .NE.  1)  GC  TO  20 
DO  10  I S=  1 , 4 
10  I ST  AT l IS)  = 0 
C SHOW  ALL  SOURCES  ARE  OFF 

JTRAN  = 0 

DO  15  MOUE=MINMOD»MAXMOD 
DO  15  I ET  A=  1,  NET  A 
15  CFTIIETA, MODE)  = 10.,  0.  ) 

C DECIDE  WHICH  SOURCES  TO  TURN  ON 

C IF  BODY  REQUESTED,  TURN  IT  ON  THE  1ST  PASS  C I S =2  FOR  BODY) 
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c 


n 


C 

c 


c 

c 

c 


c 

c 

c 

c 

c 

c 

c 

c 

c 


c 

c 

c 

c 


c 


c 

c 

c 


c 

c 


c 


20  IF  ( I BODY  .NE.  0 .AND.  HHX  .EQ.  I)  1 STA  T C 2 ) * -1 

IF  SUPERSTRUCT  REQUESTED,  TURN  IT  ON  THE  1ST  PASS  (IS=4  FOR  SUP) 
IF  ( IS  J PR  .NF.  0 . AND.  ITHX  .EQ.  1)  ISTAT(4)  = -1 
IF  WAKE  REQUESTED,  TURN  IT  ON  WHEN  X EXCEEDS  XWAKL  (BUT  DONT 
TURN  IT  ON  IF  IT  IS  ALREADY  ON)  (IS  = 3 FOR  WAKE ) 

IF  (IWAKE  .NE.  0 .AND.  X .GE.  XWAKE  .AND.  ISTATI3)  . NE . 1) 
i ISTAT! 3)  * -1 


SKIP  IF  ALL  SOURCES  ARE  OFF 
IF  (JTRAN  .EQ.  0)  GO  TO  70 

STEP  ( 1 HE  SOURCES  WFICH  ARE  ALREADY  DN)  THROUGH  DX 
DO  50  MODE=MI NMOD.MAXMOD 
DO  50  I ET  A=  1,  N ET  4 

50  CFT ( I ET  A, MODE ) = CFT ( I E T A, MO CE )*CEXD ( IE TA , MODE ) 

LCCP  FOR  EACH  bOUKCE 
70  DO  80  IS  = 2, 4 

JUMP  IF  SOURCE  IS  TO  BE  TURNED  ON  NOW 
BO  IF  C 1ST  AT  C IS  ) .EQ.  -1)  GO  TO  90 
NO  SOURCE  IS  TO  BE  TURNED  ON  NOW 
GO  TO  210 

READ  IN  TRANSFORMS  FOR  EACH  SOURCE 
90  REWIND  NTT  EM P 

IS= I D ( RECNO)  INDICATES  CONTENTS  OF  RECORD  NUM3  ER  =RE  C NO 
ISYM(RECNO)  INDICATES  SYMMETRY  OF  TRANSFORM, 

1 = HEKMIT  EAN  ANT  I -SYMMET R IC,  0 = HS,  -1=N0  SYMMETRY 
READ ( NTT  EMP ) ID, ISYM 
DO  190  MODE=MINMUD, MAXMOD 
DO  95  I ET  A= 1, NET  A 
95  CTEMPK  I ET  A ) = (0.,  0.  ) 

LCCP  FOR  EACH  SOURCE  AND  XI 

DO  180  I REC- 1,4 

JUMP  IF  GOING  TO  READ  A SOURCE 

IF  (ID(IREC)  .NE.  1)  GO  TO  150 

READ  XI 

RE AD (NTT EMP)  ( YS PA CE( I ET A ) , I ET A *1 , NE TA ) 

INSERT  (TRANSFORM!  i ) JJST  TURNED  ON)  INTO  EXISTING  TRANSFORMS 
DO  100  I ET  A- 1 , N ET  A 
ARG  * YS  PACE ( I ET  A ) «X 
100  CFT ( I ET  A, MOUE ) = CFT ( I ET A, MO DE  ) 

1 + CTEMP1(IETA)*CMPLX(C0S(ARG),  SIN ( ARG ) ) 

SKIP  IF  CGS , S 1 N ( X I « OX  ) HAVE  ALREADY  BEEN  STORED 
IF  (ISTAT  C 1 > .EQ.  1)  GO  TO  140 
DO  130  I ET  A= 1 , N ET  A 
ARG  * YSPACE( IETA)«DX 

130  CEXDI  I ET  A,  MOCE  ) = CMPL  < ( CO  SC  ARG  ),  S IN  ( ARG  ) ) 

XI  RECORD  SIGNALS  END  OF  SOURCE  RECORDS  FOR  THIS  MODE 
140  GO  TO  190 

READ  SOURCE  RtCORD 

150  READ(NTTEMP)  ( CF  FT  ( I ET  A ),  I ET  A=  1,  NE  TA  ) 

SKIP  IF  NOT  TURNING  ON  THIS  SOURCE— GET  SOURCE  NUMBER,  TEST  STATUS 
IS  = I D( IREC) 

IF  (ISTAT(IS)  .NE.  -1)  GO  TO  180 

JTRAN  SHOWS  CHARACTER  OF  NET  TRANSFORM 

1* REAL , 2=IMAUINA«Y,  3 = C0MPLEX  (3  NOT  IMPLEMENTED) 

IF  (ISYM(IREC)  .EO.  1)  JTRAN  - JTRAN  .OR.  2 
IF  (ISYM(IREC)  .EQ.  0)  JTRAN  = JTRAN  .OR.  1 
IF  (ISYM(IREC)  .EQ.  -1)  JTRAN  * JTRAN  .OR.  3 
ADD  THIS  SOURCE  INTO  SUM  OF  EMERGING  SOURCES 
00  150  IET  A=1,NET  A 

160  CTEMPl(IETA)  = CTEMPK  IETA)  ♦ CFFT(IETA) 
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* 180  CONTINJE 

190  CONTINUE 

C RESET  SOURCE  STATUS  FROM  (TURN  ON)  TO  (ON) 

DO  200  I S=  1 » 4 

. 200  IF  (ISTAT(IS)  .EU.  -1)  IS T AT ( IS)  - 1 

C SHOW  EXP(  I *X  I*DX ) HAS  BEEN  STORED 

ISTAT(i)  = I 


C SKIP  IF  ALL  SOURCES  ARE  OFF 

210  IF  (JTKAN  .EC.  0)  GO  TO  300 

C TEST  FOR  TRANSFORM  REAL,  IMAGINARY.  OR  COMPLEX 

GO  TO  (220,250  ),JTRAN 
C TRANSFORM  IS  REAL 

220  DO  240  IETA=1  .NET  A 
TEMP  = 0. 

CO  230  MUDE=M INMUD, MAX  MOD 
230  TEMP  = TEMP  + R EAL ( C FT ( IET A, MODE ) ) 

240  CFFT(IETA)  = C MPLX ( 2 . * T EMP , 0.) 

GO  TO  3 20 

C TRANSFORM  IS  IMAGINARY 

250  DO  270  I ET  A=  i , N ET  A 
TEMP  = 0. 

DO  250  MOUE=M  INMUD, MAX  MOD 
260  TEMP  = TEMP  + AI M AG( CF T ( IET A, MODE ) ) 

-270  CFFT(IETA)  = CMPLXIO.,  2.*TEMP) 

GO  TO  320 


C 

j 

c 

c 

J C 

c 


300  DO  310  I £T  A= 1 , N ET A 
310  CF  FT ( I ET  A ) = (0.,  0. ) 

320  CALL  T IMER( -10  ) 

RETURN 

END 

SUBROUTINE  FT  POT 

ADD  POTENTIAL  SOLUTION  TO  DISTURBANCE 

COMMON  /CONST/  JDK,  JDM0OE,  JOTCL,  PI,  NULL,  JDCKL , JDMFT 
1,  JDCKSV,  JDMSP,  JDEDGE 

COMMON  /CCNTRL/  ICASE,  ICKFLG(20)»  JD1SP,  JFF  T , JPOT 
1,  NOOISP,  NO OR  ID 

EQU IV AI ENCE  ( MODS E A,  ICK FLG ( 1 ) ) , ( MODO BS , ICKFlG  ( 2 ) ) 

1,  (MOD BOD,  ICKFLG( 3)  ),  (MODWAK,  ICXFLGI4)  ) , ( MODS  UP , I C KF LG  1 5 ) ) 

COMMON  /GRID/  OBSDEP,  NOBS,  DOBS,  OBSMAX,  TABOBS(IOO),  ITHOBS 

1,  X,  CX,  XMIN,  NX,  ITHX,  Y,  DY , YM1N,  NY,  ITHY,  M0DE1 , MODEN 

2,  IVAR,  IPRDT , IPPDT(9),  XPMAX,  YPMAX,  IPPPSD,  IPRE3G 

3,  ISPHAS 


COMMON  / BCDY/  I BODY , IPBODY,  BODDEP , BODDIA,  BODLEN,  BODSPD 
1,  RBSEP2,  RBSTR,  RBLIM 

COMMON  /SUPER/  ISUPR , SUPTOP,  SUPBOT,  IPSUPR,  SUSTR,  SUSEP2 
1,  SUPMID,  SULIM,  SJPDIA,  SUPLEN 


COMPLEX  VAR 

COMMON  //  ETA,  DETA,  I ETA,  NETA,  MODE,  MINMOD,  MAXMOD,  XI 

1,  RK,  CLCK,  PSIG,  DPS  10,  DPSIB,  WAKI,  SUPT,  MAXK , LOCDT 

2,  LOCDT 1(40),  IFWADT , LrfADT,  IXTRAP,  VAR,  1VSYM,  IBSYM 

3,  IWSYM,  ISSYM,  LOCDTK , JTRAN 


no 


j 


COMPLEX  CFFT,  CTEMP1,  CFT,  CEXD 

COMMON  //  CFFTI256),  CTEMP1I  256),  CFT  < 256, 40 ) , CEXD(256,^0) 
EQUIVALENCE  <YSf>ACE,CFFT) 

01  MENS  ION  YSPACtt  1 ) 

DIMENSION  Z0II4) 

C 

c 

CALL  TIMER* 12) 

IF  ( JFFT  .NE.  0)  GO  TO  6 

C NO  WAVES-- JUST  POTENTIAL  SOLN.  INITIALIZE  OUTPUT  ARRAY. 

DO  4 1=1, NY 

A-  YS  PACE  ( I)  = 0. 

C SKIP  IF  OUTSIDE  SPECIFIED  RANGE  FOR  POTENTIAL  SOLN 

6 IF  (X  .GT.  X PM  AX ) GO  TO  530 
C INOEX  OF  MAX  Y COURCINAYE 

LIM  = MINUI IFIXl YPMAX/DY )+l,  NY) 

C SKIP  IF  BODY  POTENTIAL  OPTION  OFF 

IF  (IPBCDY  .EC.  0)  GO  TO  290 
C X COORDINATE  UF  OBSERVATION  POINT  WRT  SOURCE,  SINK 

XI  = X + RBSEP2 
X2  = X - KBSEP2 
Y1S  = X 1 « *2 
)-,2S  = X2**2 

C UBIQUITOUS  FACTORS 

CON  = RBSTR/I4.«PI) 

CONU  = CON/eCCSPD 

C Z COORDINATE  UF  OBS  POINT  WRT  BODY,  IMAGE 

ZD  I ( 1 ) = -OBS  D EP  + BODDEP 
ZD  I (2)  = -OBSCEP  - BODDEP 
C LOOP  FOR  POCY,  IMAGE 

DO  210  ID-1,2 

C PICK  UP  RELATIVE  Z COORDINATE 

ZD  = ZDI(IO) 

ZDS  = ZC**2 

C PRESET  Y COORDINATE 

Y = 0. 

C LOOP  FOR  EACH  Y 

DO  200  1=1, LIM 

YS  = Y«*2 

C SQUARE  OF  TRANSVERSE  DISTANCE  TO  03S  POINT 

TS  = ZDS  + YS 

C DISTANCE  TC  CBS  POINT  FROM  SOURCE,  SINK 

R1  = SORT  ( X IS  *-TS  ) 

R2  = SQRT ( X2S+TS ) 

C 

C ' JUMP  ON  VARIABLE  TO  COMPUTE  EFFECT  OF  SOURCE+SINK  AT  THIS  DEPTH 
GO  TO  ( 10, 20, 30, AO, 50,  60,70, 80, 90,  100), I VAR 
C (U)  X-VELOCITY 

10  YSPACEII)  = YS  PACE ( I ) + CON*  I X 1/R  1**  3-X  2 /R  2*  * 3 ) 

GO  TO  200 

C (V)  Y-VELOCITY 

20  YSPACEII)  = YSPACC(I)  + CON* I Y /R l«* 3-Y/R 2«* 3) 

GO  TO  200 

C (DELTA-X)  X-CISPLACEMENT 

30  YSPACE(I)  = YSPACEII)  - CONU*(  1 ,/R  1-  1 ,/R2) 

GO  TO  200 

C (DELTA-Y)  Y-CISPLACEMEMT 

C CONTRIBUTION  IS  ZERO  FOR  TS  = 0. 

*0  IF  ITS  .EQ.  0. ) GO  TO  200 

YSPACEII)  = YSPACEII)  ♦ CONU* Y /TS* ( XI /R 1-X2 /R2 ) 

GO  TO  200 

C (DELTA-Z)  VERTICAL  CISPLACEMENT 


no  n noon 


C 


CONTRIBUTION  IS  ZtRO  F3R  TS=0. 

50  IF  (TS  .EQ.  0. ) GO  TO  200 

YS PACE  ( I ) = YS  PACE ( I ) + C0NU*ZD/TS*  I X 1/*  1-X2/K2) 

GO  TO  200 
C IEPSILON-X)  X-STRAIN 

50  Y S PACE  ( I ) = YS  PACE ! I ) + CONUM  X 1/R  1**  3-  X2/R  2*»  3) 

GO  TO  200 

C (EPSILON-Y)  Y-STRAIN 

70  IF  (TS  .EC.  0. ) GO  TO  75 
TEMP  = 1.  -2.*YS/rS 

YS  PACE ( I ) = Y S PACE ( I ) + CONJ * ( X 1/R  1# ( TEMP-Y S/k 1**2 ) 

1 -X  2/ R2* ( T EMP-YS/R2**2)  } / TS 

GC  TO  200 

C LIMIT  OF  ABOVE  AS  TS  GOES  T3  0. 

75  YS  PACE ( I ) = Y S PACE ( I ) + CON J * f - . 5 /X  1 S + . 5 /X2 S ) 

GO  TO  200 
C (GAMMA-XY) 

80  Y S PACE ( I ) = YSPACc(I)  4 2 . *2 ONU* ( Y /R i** 3- Y/R 2* * 3 ) 

GO  TO  200 

C (SIGMA)  STRAIN  RATE 

90  YS  PACE ( I ) = YSPACE(I)  - CON* ( < 1 .-3  . * ZDS/R 1* * 2 ) /R 1 *3 
I -(  l.-3.*ZDS/R2**2)/R2**3) 

GO  TO  200 

C (W)  VERTICAL  VELOCITY 

100  YS  PACE ( I ) = YS  PACE ( I ) 4-  TON* ( Z D/R 1* • 3-ZD /R 2** 3 ) 

200  Y = Y ♦ OY 
210  CONTINUE 


SKIP  IF  SUPERSTRUCTURE  NOT  TO  BE  COMPUTED 
290  IF  (IPSUPR  .EQ.  0)  GO  TO  530 

X CCORDI NAT  E OF  OBS  POINT  WRT  SOURCE,  SINK 

XI  = X - SUPMIC  + SUSCP2 
X2  * X - SUPMID  - SUSEP2 
X1S  = X 1 *«2 
X2S  = X2**2 
UBIQUITOUS  FACTORS 
CON  = SUST  R/  ( 4 . * P I ) 

CONU  = CON/eODSPD 

Z CCORDI N AT  E OF  OBS  POINT  WRT  BOTTOM,  BOTTOM  IMAGE,  TOP, 
TOP  IMAGE  OF  SUPERSTRUCTURE 
ZDI(l)  = -OBS DEP  + BOODEP  - SUPBOT 

ZD!  (2)  = -GBSUEP  - BODDEP  + SUPBOT 

ZD  I ( 3 ) = -OBSCEP  + eOODEP  - SUPTOP 

ZD  I ( 4 ) = -OBSDEP  - BODDEP  + SUPTOP 

C • LOOP  FOR  BOTTOM,  THEN  TOP  OF  SUPER 

ID  = 1 

DO  520  I KT= 1 , 2 
C LOOP  FOR  SUPER,  IMAGE 

DO  510  IS  1*1* 2 

C PICK  UP  RELATIVE  Z COORDINATE 

ZD  = ZDI  ( ID) 

ZDS  = ZD**2 
C PRESET 

Y = r . 

C LOOP  FOR  EACH  Y 

DO  500  I = 1 , L I M 
YS  = Y**2 

C SQUARE  OF  TRANSVERSE  DISTANCE  TO  OBS  PD  I NT 
TS  = ZDS  + YS 

C DISTANCE  TO  CBS  POINT  FROM  SOURCE,  SINK 

R1  = S QRT ( X1S  +TS  ) 
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R2  = SQRT I X2S  + TS  ) 

C JUMP  ON  VARIABLE  10  COMPUTE  EFFECT  OF  S3  URC  E ♦ S I NK  AT  THIS  DEPTH 

GO  TO  (310,320,  330,340,  350,  36C,  370,  380,  390, 4C0) , I VAR 
C (J) 

310  YS  PACE  ( I ) = YSPACEII)  - COM*  ( X 1 /R 1 / ( L D + R 1 ) -X2/R2  / ( ZD-M2 1 ) 

GO  TO  500 
C (V) 

320  YSPACE(I)  = YSPACEII)  - CON* (Y/RI/(ZD+R1)-Y/R2/(ZD+R2  ) ) 

GO  TO  500 
C (OELTA-X) 

330  YSPACEII)  = YSPACEII)  - CONJ *ALOG( ( Z D+R 1 ) / I ZD+R 2 ) ) 

GO  TO  500 
(DELTA-Y) 

CONTRIBUTION  IS  ZcRO  FDR  Y =0 . 

340  IF  (Y  .EU.  0. ) GO  TO  500 
TEMP  = SQRTI TS ) 

YSPACfc(I)  = YSPACEII)  - CONJ * I AS  IN  I I T S + Z D*R 1 ) / TE HP/  I ZU  + K 1 ) ) 

1 -AS  INI  I T S +ZD*R  2 ) / TEMP/I ZD+R2) ) ) 


GO  TO  500 
(DELTA-Z ) 

350  YSPACEII)  = YSPACEII)  - CONU *ALOG( I X 1 +R 1 ) / I X 2+R2 ) ) 

GO  TO  500 
IEPSILON-X ) 

360  YSPACEII)  = YSPACEII)  - CONJ*(  Xl/Rl/l  ZD+R1I-X2/R2/I  ZD+R2 ) ) 
GO  TO  500 
(EPSILON-Y  ) 

CONTRIBUTION  IS  ZERO  FOR  TS=C 
370  IF  ITS  .EQ.  0. ) GO  TO  500 

YSPACEII)  = YSPACEII)  - CONJ • I X 1/K 1* I - 1 . / I ZD+R 1 ) +ZD / TS ) 

1 -X2/R2*! -l./I ZD+R2)*ZD/TS) ) 


GO  TO  500 
IGAMMA-XY ) 

380  YSPACEII)  = YSPACEII)  - 2 . *CONU* I Y /R 1 /( ZD  + R 1 ) - Y/R2 / I ZD  + R2 ) ) 
GO  TO  500 
(SIGMA) 

390  YSPACEII)  = YSPACEII)  - CON* I Z D/R l *• 3-ZD /R2**3 ) 

GO  TO  500 

(W) 

400  YSPACEII)  = YSPACEII)  - CON*  I 1 . /R  1-  1 . /R2  ) 

500  Y = Y ♦ DY 
510  10=  ID*  1 
CON  = -CON 
CONU  = -CCNU 
520  CONTINUE 
53 G CALL  TIMERI-12) 

RETURN 

END 

SUBROUTINE  FTPSDS 

OUTPUT  PSC  DATA  TO  PP  PROCESSOR 


COMMON  /GRID/  OBSOEP,  NOBS,  COBS,  OBSMAX,  TAB0BSI100),  ITHOBS 

1,  X,  UX,  XMIN,  NX,  ITFX,  Y,  DY,  YMIN,  NY,  I THY,  MODE  1 , MODEN 

2,  I V A?> , IPRDT,  IPPDTI9),  XPMAX,  YPMAX,  IPPPSD,  I PREDG 

3,  ISPHAS 
C 

COMMON  /FILES/  NTILIB,  NTDLIB,  NTPDEF,  NTPID,  NTPDAT,  NTPLOT 
1,  NTDTAB,  NTEVEC,  NTT  EMP 

C 

COMMON  /NAME/  NAMES(2,10),  DTNAMSI2,9) 

C 

common  /pfcom/ 

1 LENPP,  PNAMfc,  PM  I M,  P^AX,  PLEN,  VMAME  , VMIN,  VMAX 
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2,  VLEN,  FNAME(2),  FMIN,  FM  AX,  FL  EM  * F TODP  * TI  TLE  (2  ) 

3,  IOCUR,  IPLTYP,  I PLOT  * IPRIMT,  ItDIT,  NP , IVLIST*  NOPP 

4,  I DPP*  KV,  IbYM 

L * ENDPP,  I BL OK  S(  1) 

COMPLEX  VAR 

COMMON  //  ETA,  DETA,  I ET  A,  META,  MODE,  MlNMOD,  MAXMOD,  XI 
It  RK,  DLDK,  PSIO,  DPSIO,  DPSIB,  WAKI,  SUPT,  MAXK,  LOCLiT 

2,  LUCCT 1 ( 40 ) , IFWADT,  LWADT,  IXTRA?,  VAR,  IVSYM,  IUSYM 

3,  IWSYM,  ISSYM,  LOC DTK  , JTRAN 
COMPLEX  CFT3CC,  CFTSUP,  CFTh AK 

COMMON  //  CET  BOD(  2 56),  CFTSUP<256),  CFTWAK ( 256 ) , TA  B XI  (256) 

1,  T KO  ( 40  ) , TK(IOO),  TL  TA  ( 100,  40)  , TDLDK  < 100, 40  , TPSI  0(  100 ,40) 

2,  TOPS  101  100,40)  , TOPS  IB<  100,  40  ) , TWAK I ( 1 00,  <t0)  , TSUP  T ( 1 00  ,40 ) 
EQUIVALENCE  ( T EMP 1 , CFT BOD ) 

01  mens  ION  TEMPI!  9,  1 ) 

RtiAL  NAMtS 

DIMENSION  NAMPS  0(2,3),  I DP  S D ( 3 ) , ID(4),  JSYM(4) 

DATA  NAM  PS  D/ 9 H PS  D( BODY ) , 1H  , 9HP  SC ( W AK  t ) , 1H  , 10HP SD ( SUP ER ) , 1H  / 

DAI  A I DPSU/4HBPS  D,  4HWPSD,  4HSPSD/ 


RETURN  IF  PSCS  ARC  NOT  TO  BE  DISPLAYED 
IF  (IPPPSC  .EQ.  0)  RETURN 
RECORD  NUMBER  OF  SOURCE  TO  PP  NEXT 
IPPREC  = 1 
10  REWIND  NTT  EMP 

RE  AD( NTT  EMP ) ID,JSYM 
I D ( I ) = SGURCc  NUMBER  IS  OF  RECORD  I 

IS—  1 = X I (WHICH  IS  LAST  RECORD  OF  MODE),  2=bJDY,  3^WAKE,  4=SUPER 
IS  = I D ( IPPREC) 

INITIALIZE  PP  SPECS  FOR  SJURCE  IS 

CALL  SET  IU(  iCPSD(  IS-i),  1,  4HM0DE,  3HETA,  NAMP  SO  ( 1 , 1 S- 1 ) ) 

LOOP  FOR  -ACH  MODE 

CO  50  MOLE=M  INMOO, MAXMOC 

ITHREC  = 1 

READ  RECORD  NUMBER  ITHREC  FOR  THIS  MODE 
USE  CFTBGD  AS  TEMP  STORAGE 
20  RE  AD ( NTT  EM  P)  ( CFT BQC( I ET A ) , I ET A = 1 , NE T A ) 

SKIP  IF  THIS  IS  NOT  THE  SOURCE  WE  WANT 
IF  (ITHREC  .NE.  IPPREC)  GO  TO  40 

(SEE  COMMENTS  IN  FT  CON ) . ASSUME  HERE  THAT  TP  = +3R-TM.  THEN 
ONLY  TP  WAS  WRITTEN  ON  THE  FILE.  P SL>  = ( 2»  TP  ) * *2 
DO  30  I ET  A=  1,  NET  A 

3.0  TEMPl(IETA)  = 4.  *(  REAL  ( CFT  BOD(  I ETA  ) )«*2  + A I MA  G ( C F TBOD  ( I E TA  ) ) »*2  ) 
COMPUTE  ANC  FLOAT  ACT  J AL  MODE  NUMBER 
RMODE  = MODE  + M0UE1  -1 
WRITE  THE  PSC  DATA  FOR  THE  PP  PROCESSOR 
CALL  WRTD  AT  ( 1 , NETA,  TEMPI,  1,  RMODE) 

BUM°  RECORD  NUMBER  AND  LOOP  BACK  FOR  NEXT  SOURCE 
40  ITHREC  = IThRLC  ♦ 1 

IF  C ID  C ITHREC)  .NE.  1)  GO  TO  20 

LAST  RECORD  CF  EACH  MOOE  IS  XI 

RE AD( NTT  EMP ) (TEMP1(  I ET  A ) , IETA  = 1,NETA  ) 

50  CONTINUE 

WRAP  UP  PP  SPECS  ANC  WRITE  THEM 
V MI  N = 0. 

VMAX  = DEf  A«FLOAT(  NETA-I) 

NOTE  THAT  NAMES  HAS  BEEN  MADE  REAL 
TITLE(l)  = NAMES ( 1 , IVAR ) 


114 


OO  o o o oooooooo 


T IT  LE  ( ? ) = NAMES!  2,  IVAR  ) 

CALL  WRT  I C (NET  A,  0,0) 

C MOVE  UP  TO  NEXT  RfcCORO,  I OOP  IF  IT  IS  ANOTHER  SOURIE 

IPPREC  = IPPREC  ♦ I 
IF  { 1 0 ( IPPREC)  .NE.  1)  GO  TO  10 
RETURN 
END 

SUBROUTINE  FTSRC 

C COMPUTE  TRANSFORM  POINT  FOR  CURRENT  ETA,  MODE 

C 

COMMON  /BODY/  I BODY , IPBODY,  RODDEP » BOODIA,  JOOLEN  , BOOSPD 
1,  RESEP2,  RBSTR,  RBLI^ 

o 

CUMMON  /SUPER/  ISUPR,  SUPTOP,  SUPBOT,  IPSUPR,  SUSTR,  SUSCP2 
1,  SUPMID,  SJLIM,  SJPDIA,  SUPLEN 

C 

COMMON  /WAKE/  IWAKE,  CrfAKK,  CWAKX,  XWA<E  , WAKRAO,  XWNtJM 
1,  RESLVS,  CWAKM 

C 

COMPLEX  VAR 

COMMON  //  ETA,  DET  A,  IETA,  NETA,  MODE,  MINMOD,  MAXMOD,  XI 

1,  RK,  OLDK,  PSIO,  DPS  1 0,  DPSIB,  WAX  I , SUPT,  MAXK,  LOCDT 

2,  L0CDT1I 40 ) • IFW4DT,  LWADT,  IXTRAP,  VAR,  IVSYM,  IBSYM 

3,  IWSYM,  1SSYM,  LOCDTK,  JTRAN 

COMPLEX  CFTBCC,  CFTSUP,  CFTWAK 

COMMON//  CFT  BOD( 256 ) , CFTSUP(256),  C FTWAK I 256 ) , TABXII256) 

1,  T KO ( 40  I , TK(IOO),  TE TA{  100, 40) , TOLDK ( 1 CO , 40)  , TPSI 0 ( 1 00  ,40 ) 

2,  TDPS 1 0 1 100,40 ),  i OPS IB(  100, 40) , TWAKI I 100,40)  , T SUPT ( 1 00 ,40 ) 
EQUIVALENCE  (T EMP1, CFT BOC > 

01  MENS  I CN  TEMPK9,  1) 

COMPLEX  S 


NOTE  THAT  S= INT EGRAL ( F*PS I *DZ ) . IBSYM, I WSYM, I SSYM  INDICATE  THE 
SYMMETRY  OF  Ti  (SEE  FTCDN  COMMENTS)  FDR  THE  BODY,  WAKE,  SUPER  WHEN 
XI  CHANGES  SIGN — 1=  HERM IT  EAN  ANTI-SYMMETRIC,  0=HERMI TE AN 
SYMMETRIC,  -1=N0  SYMMETRY 

SKIP  IF  BOOY  OFF 
IF  ( I BOOY  .EG.  0)  GO  TO  100 
IF  (IBOCY  .EG.  2)  GO  TO  20 
RANKINE  BODY 

RBSTR=  SOURCE  STRENGTH,  RBSEP2  = i/Z  SOURCE  TO  SINK  SEPARATION 
S = CMPLX ( 0 . , -2.*RBSTR*DPSIB*SIN(XI*RBSEP2) ) 

CFTBOO(IETA)  = S*VAR 
IBSYM  = IVSYM 
GU  TO  100 

DIPOLE  BODY . RBL IM=L I MI RB ST R*R BSEP 2 ) 

20  S = CMPLX (0 . , -2 .*REL IM*DPSIB*X  I ) 

CFT  BOD (IETA)  = S*VAR 
IBSYM  = IVSYM 

SKIP  IF  WAKE  IS  OFF 
100  IF  (IWAKE  .EQ.  0)  GO  TO  200 

S = CMPLX ( -WAK I*C0SI X I *XWAKE  ),  WAK I* S INI  XI* XWAKE ) ) 

CFTWAKI  IETA)  = S *V  AR 
IWSYM  = IVSYM 
C 

C SKIP  IF  SUPERSTRUCTURE  IS  OFF 

200  IF  (ISUPR  .EQ.  0)  GO  TO  300 
IF  ( IS J PR  .EC.  2)  GO  TO  220 

C OVAL  SUPERSTRUCTURE.  SUSTR=SOURCE  STRENGTH,  SUSfcP2=l/2  SOURCt 
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C TO  SINK  SEPARATION,  S JP T =P S I ( B QT  )-P S I ( TOP ) 

TEMP  = 2.*SUSTR*SUPT*SIN(X I*SUSEP2) 

C SU  PMI  D = X COORD  I NA1  E OF  MIDDLE  OF  SUPERSTRUCTURE 

S = CMPLX (TLMP*S IN( X I*SUPM ID ),  T EMP*CO S( X I * SUPM I D ) ) 
CFTSUPI  I L T A ) = S *VAR 
ISSYM  = IVSYM 
GO  TO  300 

C CIRCULAR  SUPER.  SUL IM  = L IM ( SUSTR* SUSEP2 ) 

220  TEMP  = 2 . *SUL l M*SUPT*X I 

S = CMPLX (TEMP*S I N ( X I*SJPM ID ) , T EMP*COS ( X I « SUPM 1 0 ) ) 
CFTSUP ( I ET  A ) = S *V AR 
ISSYM  = IVSYM 


C 

300  RETURN 
END 

SUBROUTINE  FTV  AR 

C COMPUTE  THE  VARIABLE-DEPENDENT  (BUT  SOURCE-INDEPENDENT)  PART  OF 

C THE  TRANSFORM 

C 

COMMON  /BLDY/  I BODY , IPBOOY,  BODDEP , riODD  I A , rtOQLEN  , BQDSPD 
1,  RUSEP2,  RBSTR,  RBLIM 

C 

COMMON  /GRID/  OBSDEP,  NOBS,  DOBS,  OBSMAX,  TABOd S ( 1 00)  , I THObS 

1,  X,  DX,  XMIN,  NX,  I THX , Y,  DY , YMIN,  NY,  ITHY,  MODE  1 , MODEN 

2,  I V AR , IPRDT,  IPPDTI9),  XPMAX,  YPMAX,  IPPPSD,  IPRlDG 

3,  ISPHAS 
C 

COMMON  /NAME/  NAMLS(2,10),  DTNAMS(2,9) 


C 


c 

c 

c 

c 


c 

c 


c 

c 


c 

c 


c 


COMPLEX  VAR 

COMMON  //  ETA,  DETA,  I ETA,  NETA,  MODE,  MINMOD,  MAXMOD,  XI 

1,  RK,  DLCK , PSIC,  DPS  10,  DPSIB,  WA* I , SUPT , MAXK,  LOCDT 

2,  L0CDT1  ( -,0 ) , IFWADT,  LWAUT,  IXTPAP,  VAR,  IVSYM,  IBSYM 


3,  IWSYM, 

data  names/ 

1 , 

2, 

3, 

4, 


ISSYM,  LOCDTK , J T RAN 
20HX -VELOCITY  (U)  , 

^OHX-DISPL ACE  (DELTA-X), 


2 OHY- VELUC I TY  (V) 
20HY-DI SPLACE  (DELTA-Y) 


.OHZ-DI SPL  ACE  (DELTA-Z),  ZOHX-STRAIN  (EPSILON-X) 


20HY-STRAIN  (EPSILON-Y), 
ZOPDiL AT  AT  ION  ( SIGMA  ) , 


20HSHEAR  STRN  (GAMMAXY) 
20HZ-VELU:i  TY  ( W) 


IVSYM,  1 = V AR  IS  HERMITEAN  AN T I - SYMME TR IC  IN  XI,  0=H.  SYMMETRIC , 
-1  = NO  SYMMETRY  IN  XI  (THIS  CASE  HAS  NOT  BEEN  IMPLEMENTED) 

TEMP  = 2.»XI»(  2.*RK/DLDK*(  ET  A/(  B0DSPD*XI**2)  )*»2  +1.) 

TEMP  = l./TEMP 

. GOTO  ( 10,20,30,40,50,  60,^0,  60,  90, 100),  IVAR 

(in  DOWN  TRACK  VELOCITY  DISTURBANCE 
10  VAR  = CMPLX(TEMP»DPSID*XI/RR**2,  0.) 

IVSYM  = 0 
GO  TO  200 

(V)  CROSS  TRACK  VELOCITY 
20  VAR  = CMPLX (TEMP»DPS I0*ETA/RK**2,  0.) 

IVSYM  = 1 
GO  TO  200 

(DELTA-X)  DOWN  TRACK  DISPLACEMENT 
30  VAR  = CMPLX ( 0 . , -T EMP* DPS l 0/ ( BODSP D»RK» • 2 ) ) 

IVSYM  = 0 
GO  TO  200 
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C (OELTA-V)  CROSS  TRACK  DISPLACEMENT 

AO  VAR  = CMPLX  ( 0 . , -T  EMP*OPS  10*  ET  A/I  BODSPD*  XI*RK*  * 2 )) 

IVSYM  = j. 

GO  TO  200 
C 

C (PELTA-Z)  VERTICAL  C IS  P L AC  EM  £N  T 

50  VAR  = CMPLX(-TEMP»PSIO/(fiODSPD*XI),  0.) 

IVSYM  = 0 
GO  TO  200 

(EPSILUN-X)  DOWN  TRACK  STRAIN 
60  VAR  = CMPLX(TEMP*0PSI0*XI/(B00SPD*RK**2),  0.1 
IVSYM  = 0 
GO  TO  200 
C 

C (EPSILON-Y)  CROSS  TRACK  STRAIN 

70  VAR  = CMPLX (T  EMP»OPS I0»ETA*»2/( B0DSPD«XI*RK**2 ) » 0.) 

IVSYM  = 0 
GO  TO  200 
C 

C ( G AMMA-X Y ) SHEARING  STRAIN  IN  HORIZONTAL  PLANE 

80  VAR  = CMPLX(TlMP«DPSI0*2.*£TA/(B0DS?D**K**2),  0.) 

ivsym  = : 

GO  TO  200 
C 

C (SIGMA)  HORIZONTAL  PLANE  DILATATION 

9 0 *}(  R - C MPt.X  ( 0 . « TEMP*DPSIG) 

IVSYM  = 0 
GO  TO  200 
C 

C (W)  VERTICAL  VELOCITY 

100  VAR  = CMPLX  ( 0 . » -TEMP*PsIll) 

IVSYM  = 0 
C 
C 

200  PETL-kN 
END 

SUBROUTINE  FT  R I T 

C WRITE  TRANSFORMS  FOR  EACH  SOURCE  ON  FILE  NTTEMP 

C 

COMMON  /BODY/  I BODY  v IPttOOY,  BODDEP » B3DDIA,  BUOLEN,  BODSPD 
1,  RBSEP2,  RBSTR,  RBLIM 

C 

common  /files/  ntilib,  NTDLIB,  ntpdef,  ntpid,  ntpdat,  ntplot 

1,  NT  DT  A B , NTEVEC,  NTTEMP 

c • 

COMMON  /SUPER/  ISUPR,  SUPTOP*  SUPBOT,  IPSUPR,  SUSTR » SUSEP2 
1,  SUPMIC,  SULIM,  SJPDIA,  SUPLEN 

C 

COMMON  /wake/  iwake,  cwakr,  cwakx,  xwa.ke,  wakrao,  xwnom 

1,  RESLVS,  CWAKM 

c 

COMPLEX  VAR 

COMMON  //  ETA,  CtT  A,  I ET  A,  NETA,  MODE,  MINMOD,  MAXMUD,  XI 

1,  RK,  OLOK,  PSIO,  DPS  10,  DPSIB,  WAK I , SUP T , MAXK,  LOCDT 

2,  LCOOTIUO),  IFWADT,  LW  ACT , IXTRAP,  VAR,  IVSYM,  IBSYM 

3,  IWSYM,  ISSYM,  LOC DTK , JTRAN 
COMPLEX  CFTBOC,  CFTSUP,  CFTWAK 

COMMON  //  CFTB0D(256),  CFTSUP<  256),  CFTWAK(256),  TAB X I (256) 

1,  TKO(AO),  TK(IOO),  T ETA ( 1 00, AO ) , TDLDK ( 1 00, AO)  , TP  SI  0 ( 1 00 , AO ) 

2,  TOPS  I0(  100,  AO),  T DPS  IB  ( 100,  AO),  TWAKI  ( 100,  AO)  , TSUP  T ( 1 00  , AO ) 
EQUIVALENCE  ( T EMPl, CFT BOD) 
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01  HENS  ION  T EMPK  9,  1 ) 

01  HENS  ICN  ICK  ),  ISYMI  A ) 


TD(NREC)  IDENTIFIES  1 HE  CONTENTS  OF  RECORD  NUMBER  NREC 

SETTINGS  ARE  1 = X 1 , 2=B0DY,  3=WAKE,  4 = SUP  ERSTRUCTURE 

JSYMINREC)  INDICATES  THE  SYMMETRY  OF  THE  CORRESPONDING  TRANSFORM 

SKIP  IF  NOT  1ST  PASS 

IF  (MODE  .NE.  MINMOC)  GO  TO  60 

NREC  = 0 

IT  ( I BODY  .EC.  0)  GO  TO  10 
NREC  = NREC+1 
ID(NREC)  = 2 
ISYH(NREC)  = IBSYM 

10  IF  (IWAKE  .EO.  0)  GO  TO  20 
NREC  = NKEC+1 
IDINREC)  = 3 
ISYM(NREC)  = IWSYM 

20  IF  ! 1SUPR  .EC.  0)  GO  TO  5C 
NREC  = NREC+1 
IDINREC)  = A 
ISYMI NREC ) = 1SSYM 
XI  MUST  BE  LAST 
50  NREC  = NREC+1 
I U I NREC ) = 1 
ISYMINREC)  = 0 
REWIND  NTT  EH P 
WRITE!  NT  f EMP)  ID,  ISYM 

WRITE  TRANSFORMS  IN  SAME  ORDER  AS  SOURCES  ABOVE 
60  IF  I I BODY  .EC.  0)  GO  TO  70 

WRITE!  NTT  EMP)  (CFTeODI  I ET A ),  IETA=1,NETA  ) 

70  IF  (IWAKE  .EQ.  0)  GO  TO  80 

WRITE! NTTEMP)  (CFTWAK!  I ET A ) , I ETA  = 1 , NE T A ) 

80  IF  (ISUPR  .EC.  0)  GO  TO  110 

WRITE!  NTT  EMP)  (CFTSUP!  I ET  A ) , IETA=1»NETA  ) 

110  WRITE! NTT  EMP ) ( T ABX  I < I E T A ) , I ET A= 1 , NET A ) 

RETURN 

END 

SUBROUTINE  I NOON 
INPUT  CONTROL  ROUT INE 

COMMON  /CLNTRt/  1CA$E,  ICKFLGI20),  JDISP,  JFFT , JPOT 
1,  NCDISP,  NOGRIC 

EUUI VALENCE  ( MODS £A , IC < FLG! 1 ) ) , I MODOBS, ICKFLG ( 2 ) ) 

1,  ( MOUBOD,  ICKFLG!  3 ) ),  ( MODW  AK  , IC  K FL  3 ( A ) ) , ( MOD  S UP  , I C KF  L3  ( 5 ) ) 

COMMON  II  LENCK,  NBLO<S,  ITHCUM,  IDENT,  ITHTYP,  INTYPE 
1,  LSTCHK! 1000) , L S T S AV ! 1 COOC ) 

•••••summary  of  APPROACH** *• * 

FRCGRAM  INPUT  MAY  CCMIE  FROM  3 SOURCES 

1.  INPUT  FILE  (NAMELIST  DECK  IMMEDIATELY  FOLLOWING  AN  I NP 
CONTROL  CARD) 

2.  DATA  LIBRARY  FILE  (LIB  CARD  IN  INPUT  STREAM  SPECIFIES  WHICH 
NAMELIST  DECK  TO  READ  FROM  LIBRARY  FILE) 

3.  DISPERSION  TABLE  FILE  ( HANDl  ED  BY  D T ROUTINES,  NOT  HERE) 

THE  CHECKLIST  IS  A LIST  OF  INPUT  VARIABLES  WITH  ONE  OR  MORF 
FLAGS  SPECIFIED  FOR  EACH  VARIABLE.  THE  PROGRAM  SAVES  ALL 
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C CHECKLIST  VARIABLES  BEFORE  REAOING  INPUT  AND  COMPARES  VALUES 

C AFTER  INPUT,  SETTING  FLAGS  INDICATING  CHANGES.  IN  MULTI-CASE 

C JOBS,  THIS  PERMITS  THE  PROGRAM  TO  OETERMINE  WHAT  RESULTS  CAN  BE 

C CARRIEO  OVER  FROM  THE  PREVIOUS  CASE  AND  WHAT  MUST  BE  RECOMPUTEO. 

C 

C OUTPUT  FORMAT  SPECIFICATIONS  CAN  BE  INPUT  FOR  EACH  SET  OF  DATA 

C SENT  TO  THE  PRINT/PLOT  ( PP ) PROCESSOR.  SPECS  FOR  ALL  PP  SETS 

C ARE  INPUT  TO  A SINGLE  SET  OF  VARIABLES.  TWO  OF  THOSE  VARIABLES 

C (IOPP  ANO  IOCUR)  ICENTIFY  THE  PARTICULAR  PP  SET  TO  WHICH  THE 

C SPECS  APPLY.  BEFORE  REAOING  ANY  PP  SPEC,  NULL  VALUES  ARE 

C INSERTED  IN  THE  PP  INPJT  VARIABLES.  AFTER  READING,  THE  VALUtS 

C ARE  MOV  EO  TO  A SAVE  ARRAY  UNTIL  ENO  OF  INPUT  PROCESSING  WHCN 

C THEY  ARE  ALL  WRITTEN  ON  A FILE.  AT  THE  START  OF  THE  NEXT  CASE, 

C THIS  FILE  IS  READ  SO  THAT  PP  SPECS  WILL  ACCUMULATE  FROM  CASE 

C TO  CASE. 

C 

C 

CALL  TIMER! 1 ) 

C BUMP  CASE  NUMBER  (=0  ON  1ST  CALL  TO  INCON) 

ICASE  = ICASE  ♦ 1 

C CNCE  PER  RUN  INITIALIZATIONS 

IF  (ICASE  .EQ.  1)  CALL  INRJN1 
C RESTORE  PRINT/PLOT  OATA 

CALL  INRSPP 

C SET  UP  CHECK  LIST 

CALL  INCKO 

C SAVE  CHECK  LIST  VARIABLES  BEFORE  INPUT 

CALL  INSVCK 
C 

C RE AO  INPUT  PROCESSOR  CDMMANO 

10  CALL  INRCOM 

GO  TO  120,30,40,  50  ),  ITHCOM 
C READ  INPUT  OATA  FROM  TAPE  5 

20  C*LL  I NRDAT I 5 ) 

GO  TO  10 
C 

C READ  LIBRARY  DATA 

30  CALL  INLIB 
GO  TO  10 
C 

C END  OF  RUN — NO  RETURN 

40  CALL  ENDRUN 
C 

C ENO  OF  CASE  INPUT.  COMPARE  VARIABLES  AFTER  INPUT  WITH 

C VALUES  SAVED  BEFORE  INPUT,  SET  APPROPRIATE  CKCCK  LIST  FLAGS 

■ 50  CALL  INCHK 
C SAVE  P/P  DATA 

CALL  INSVPP 
CALL  TIMERI-l! 

C RETURN  TO  EXECUTE  THE  CASE 

RETURN 
END 

SUBROUTINE  INCHK 

C COMPARE  VARIABLES  IN  CHECKLIST  WITH  THOSE  SAVED  PREVIOUSLY 

C 

COMMON  /CCNTRL/  ICASE,  ICKFLGI20),  JOISP,  JFFT,  JPOT 
1,  NOOISP,  NOGRIC 

EQUIVALENCE  ( MOOS EA, IC< FlGI 1 ) ) , ( MODOBS, ICKFLG ( 2 ) ) 

1,  (MOO BOO, ICKFLGI 3 ) ),  (MODWAK, ICKFLG(4) ) , (MODSUP , ICKF LG (5 ) ) 

C 

COMMON  //  LENCK,  N8L0KS , ITHCOM,  IDENT,  ITHTYP,  INTYPl 
1,  LST CHK ( 1000 ) , LSTSAV l 1C000) 


I 
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01  MENS  ION  leas  E(  1 ) 


INDEX  INTO  CHECKLIST  VARIABLE  STORAGE 
I S AV  = 0 

C DIVISORS  TO  SHIFT  6 AND  12  1 C T AL  DIGITS 

I SHP6  = 8**6 
ISHF12  = 6**1*: 

C INITIALLY,  SET  FUk  ALL  CHECKLIST  FLAGS  OFF 

I FLAG  = 0 
C 

C LOOP  FOP  EACH  ENT kY  IN  CHECKLIST 

DO  BO  I T HCK= 1 , L ENCK 

C PICK  UP  TEST,  DIMENSION,  LOC  OF  NEXT  ENTRY  IN  C-tKLIST. 

C REMOVE  FLAG  BITS 

ITEST  = LSTCHK ( ITHCK ) .AND.  77 7 7777 7 7 7777B 
C MASK  FOR  ACCHESS,  CROP  TEST  AND  DIMENSION 

LOC  = ITEST  .AND.  777777B 
C CCNVlKT  ABSOLUTE  ADDRESS  TO  IBASE  INDEX 

LOC  = LOC  -LGCFI  I BASE ) +1 
C SHIFT  OUT  ACCRESS 

I D I M = ITcST/ ISHF6 

C MASK  FOR  CIMlNSION,  REMOVE  TEST 

IDIM  = IDIM  .AND.  777777B 

C SHIFT  OUT  C I ML  NS  I JN  AND  ADDRESS,  RETAIN  TEST 

ITFST  = IT  EST/  ISHF12 
GC  TO  (10,20,30,  AO,  50,  60),  ITEST 
C 

10  DO  15  1=1,  ICIM 

I S AV  = ISAV  + 1 

IF  (IBASE(LOC)  .NL.  L S T S AV ( I S AV  ) ) GO  TO  70 
15  LOC  = LOC  + 1 
GO  TO  80 
C 

20  DO  25  I = i , ICIM 
I S AV  = ISAV+1 

IF  (IBASE(LCC)  .LT.  LS  T S AV  ( I S AV  ) ) GO  TO  70 
25  LOC  = '.OC+1 
GO  TO  30 
C 

30  DO  35  1 = 1 , ICIM 

I S AV  = ISAV  + 1 

IF  ( I B AS E ( LOC ) .Lt.  LSTSAV(ISAV))  GO  TO  70 
35  LOC  = LOC+1 
GO  TO  80 
C 

AO  DO  A 5 1=1, ICIM 

ISAV  = ISAV+1 

IF  (IBASE(LCC)  .EC.  LST SAV ( I SAV  ) ) GO  TO  70 
A 5 LOC  = LOC+1 
GO  TO  BO 
C 

50  DO  55  1 = 1,  ICIM 

i S AV  = I S AV  + 1 

IF  (IBASE(LOC)  .GE.  L S T S AV ( I SAV  ) ) GO  TO  70 
55  LOC  = LOC+1 
GO  TO  80 
C 

60  00  65  1=1,  ICIM 

ISAV  = ISAV+1 

IF  (IBASE(LOC)  .GT.  LS  T S AV  ( I S AV  ) ) GO  TO  70 
65  LOC  = LOC+1 
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GO  TO  BO 

TEST  IS  SATISFIED.  MASK  TO  SAVE  FLAGS,  REMOVE  OTHER  STUFF 
70  ITEMP  = LSTCHK ( ITHCK  ) .AND.  77 77777COCOOCCCCCOOOB 

SET  TO  TURN  UN  ALL  FLAGS  ASSOCIATED  WITH  THIS  VARIABLE 
IFLAG  = I FLAG  .OR.  ITEMP 
80  CONTINUE 

SET  INDIVIDUAL  FLAGS  BASED  ON  BITS  IN  IFLAG 

WASH  = 4000000000000  B 

DO  100  1=1,20 

SHIFT  THE  ON  BIT  LEFT  BV  1 

MASK  = MASK  + MASK 

PICK  OUT  CORRESPONDING  BIT  IN  IFLAG 
ITEMP  = MASK  .AND.  IFLAG 
I CKFLG ( II  = 0 

100  IF  (ITEMP  .NE.  0)  ICKFLG(I)  = 1 
RETURN 
END 

SUBROUTINE  INCKO 
SET  UP  CHECKLIST 

COMMON  /BODY/  I BODY , IPBODY,  BODDEP,  BDDDIA,  BODLEN,  HODSPO 

1,  RBSEP2,  RBSTR,  RBLIM 

COMMON  /CONST/  JDK,  JOMODE,  JDTCL,  PI,  NULL,  JDEKL,  JDMFT 
1,  JDCKSV,  JDMSP,  JOEDGE 

COMMON  /CCNTRL/  ICASE,  ICKFLG(20),  JDISP,  JFFT,  JPOT 
1,  NCDISP,  NUGRIC 

EQUIVALENCE  (MODSEA, ICKFLGI 1 ) ),  ( MODOBS, 1CKFL5 ( 2 II 
1,  ( MODBOD,  ICKFLG(  3 I I,  ( MOD WAX , ICKFLGI4) ) , ( MOD  SUP , I C KF  LG ( 5 I I 

COMMON  /GRIC/  OBSDEP,  NOBS,  DOBS,  OBSMAX,  TABDBS(IOO),  ITHOBS 

1,  X,  DX,  XMIN,  NX,  I THX,  Y,  DY,  YMIN,  NY,  ITHY,  M0DE1,  MODEN 

2,  IVAR,  IPROT,  I PP  DT( 9 ),  XPMAX,  YPMAX,  IPPPSD,  I PRED3 

3,  ISPHAS 

COMMON  /OCEAN/  LIBSEA,  MODES,  NK,  TABK(IOO),  NZT,  DKRAT , DTDEP 

1,  TDEPMX,  TDEP(AOO),  N FL  AG,  SQBV(400),  OCNDEP,  RKMAX 

2,  SQNI400I,  NKT , IPPVEC 

COMMON  /SUPER/  ISUPR,  SUPTOP,  SUPBOT,  1PSUPR,  SUSTR,  SUSEP2 
1,  SUPMID,  SULIM,  SJPDIA,  SUPLEN 

COMMON  /WAKE/  IWAKE,  CWAKR,  CWAKX,  XWAKE,  WAKRAD,  XWNOM 
1,  RESLVS , CWAKM 

COMMON  //  LENCK,  NBLOKS , ITHCOM,  IDENT,  ITHTYP  , INTYPE 
1,  LSTCHK ( 1000  I , LSTSAV( 1C000) 

INTEGER  EQ.GE.GT 

DATA  NE»LT,LE,  EQ,GE,GT/1,2,3,4»5»6/ 

t 

■ TURN  ON  A DIFFERENT  BIT  FOR  EACH  CHECKLIST  FLAG 

ION  = 40000000 00 000 B 
DO  10  1*1,20 

; SHIFT  THE  ON  BIT  LEFT  BY  1 

ION  * ION  ♦ ION 
10  ICKFLGt 1 1 * ION 

; INITIALIZE  NUMBER  OF  ENTRIES  IN  CHECKLIST 


LENCK  = 0 

SET  UP  CHECKLIST.  EACH  CALL  TO  INCK1  INStRTS  i ENTRY 
INTO  CHECKLIST 

CALL  I NCK 1 (V  ARBLE,  DIMEN,  T t ST  , FLAGS ) 
cperaticn  IS 
FLAGS  = 0 

IF  (VAKBLcI AFTERIN  POT ) .TEST.  V AR BLt l BEFORE  I NP U f ) ) FLAGS  = 1 
CALL  INCKKNK,  l,Nt,  MOOSEA) 

CALL  I NCKKCKRAT,  i,NE,  MOOSEA) 

CALL  1NCKKRKMAX  , 1 , N E,  MOOSEA) 

CALL  INCKHTABK, JDK, NE, MOOSEA) 

CALL  INCKKUCNCEP.  li  NE,  MOOSEA  ) 

CALL  1 NCKKMCCES,  1,GT, MOOSEA  ) 

CALL  1NCKK  NZT  , 1,NE,  MOOSEA  ) 

CALL  INCKKTCEP,  JDTCL,  NE,  MOOSEA  ) 

CALL  1NCKKSQBV,  J OT  CL , N E,  MOO  SE  A ) 

CALL  INCKKCTCEP.l.NE, MOOSEA) 

CALL  INCKKTDtPMX,  1,  NE,  MOOSEA  ) 

CALL  INCKKNFLAG,  1»NE, MOOSEA  ) 

CALL  INCKlIOesCEP,  l.NEiMOOOBS) 

CALL  I NCK1 (BCCOEP, 1,  NE, M00B3 C ♦MOO SUP  +MDDWAK ) 

CALL  INLKKSUPTOP,  1,NE,  MOOSUP  ) 

CALL  INCKKSUPBOT,  1,NE, MOOSUP) 

CALL  I NCK i ( I BODY  , i , GT , MOOBOO  ) 

CALL  I NCK I ( ISUPR, 1, GT , MOOSUP  ) 

CALL  INCKK  IWAKE,  1,GT,  MOPh'AK  ) 

CALL  I NCK1( BOCSPD, 1, NE, MOOWAK  ) 

CALL  I NCKK  BOCCIA,  1,  NE,  MOOWAK  ) 

CALL  INCK1  (CWAK.R,  l.NE,  MQDWAK  ) 

CALL  INCKKRESLVS,  i,NE,  MOOWAK  ) 

RETURN 

END 

SUB ROUT  INC  I NCK 11  VAR, I DIM,  I TEST,  I FLAGS) 

INSERT  1 ENTRY  INTO  CHECKLIST 

COMMON  /CONST/  JCK,  JDMOOt,  JDTCL,  PI,  NULL,  JDCKL , JD  MF  T 
1,  JDCKSV , J CMS  P,  JOEDGE 

COMMON  //  LENCK,  vlPLOKS,  ITHCUM,  IDENT,  ITHTYP,  1 NT  YPE 
1,  LSTCHKI 1000),  LSTSAVI 1CC00) 

OAT  A 16, 112/1000 OOOB,  1 0000 CC CC CCCCB / 


BUMP  NUMBER  OF  ENTRIES 
LENCK  = LLNCK+1 

IF  (LENCK  .LE.  JOCKL)  GO  TO  20 
WR I TE ( 6 , 10 ) JOCKL 

10  FORMAT  ( 1 1 H C IM  ENS  ION  = , I 6,  2 2H  OF  CHECKLIST  EXCEcDED) 

CALL  cRRXIT 

THE  OCTAL  REPRESENTATION  OF  THE  ENTRY  IS  FF FFF F F TDODD DDL LL LLL 
WHERE  F ARE  FLAG  BITS,  T IS  TEST  TO  APPLY,  0 IS 
DIMENSION,  L IS  LOG  OF  VARIABLE 
20  LSTCHK (LENCK)  = LUCF(VAR)  ♦ 16*  1 0 IM  ♦ I12*ITESi  ♦ I F LAG  S 
RETURN 
END 

SUBROUTINE  INLIB 

READ  OESIREC  DATA  SET  FROM  DATA  LIBRARY  FILE 

COMMON  /FILES/  NTILIB,  NTOLIB,  NTPDEF,  NTPID,  NTPDAT,  N T P L 0 T 
1,  NTDTAB,  NT  EV  EC,  NTTEM? 
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COMMON  //  LENCK,  NBIOKS,  ITHCOM,  1DENT,  1THTYP,  INTYPE 
1,  LSTCHKI IOOO) , LSTSAVI ICCCO) 

C 

C 

C NAMELIST  DECKS  ARE  SEPARATED  BY  CARDS  DF  THE  FORM  *T,I  WHERE 

C # IS  IN  CCi  * T = ( 1 CHAR  DATA  TYPE),  I = ( 10  CHAR  10) 

REWIND  NT ILIB 

C LCOP  THROUGH  CARDS  IN  LIBRARY  LOOKING  FDR  * IN  CC  1 

10  READINT ILIB, 20 ) I CC I , I T REF , I DR E F 
20  FORMAT  (2AL, IX,  A10) 

IF  (ICCI  .inIE.  IH*)  GO  TO  10 

C FCUNO  A DECK  SEPARATOR.  LAST  CARD  DN  LIB  FlL  = IS  *>  E ND 

IF  (ITREF  .NE.  1HE ) GO  TO  40 
WRITE (6 ,30 ) INTYPE, IOENT 

30  FORMAT ( 29  H LIBRARY  CAT  A SET  NOT  FOUND-- , A 1 , 1H , , A 1 0 ) 

CALL  ERRX  »T 

C CHECK  FOR  PROPER  TYPE  AND  ID 

40  IF  (ITREF  .NE.  INTYPE)  GO  TO  10 
IF  (IDREF  .NE.  IOENT)  GO  TD  10 
C EVERYTHING  MAICHES.  READ  NAMELIST  QECK  FROM  L13RARY 

CALL  I NRDAT ( NT  ILIB) 

RETURN 

END 

SUBROUTINl  INMVPP 

C MOVE  INPUT  PP  BLOCK  TO  IBLO<S  ARRAY 

C 

COMMON  /CONST/  JDK,  J0M3DE,  JDTCL,  Pi,  NULL,  JDCKL , JDMFT 
1,  JOCKS  V , JDMSP,  JOEOGE 

C 

COMMON  //  LENCK,  NBLOKS,  ITHCOM,  IDENT,  I THTYP  , INTYPE 

1,  LSTCHK ( 1000 ) , LSTSAVI 1CC0C) 

COMMON// 

1 LENPP,  PNAME,  PMIN,  PMAX,  PLEN,  VNAME,  VMIN,  VMAX 

2,  V LEN , FN  AM  E ( 2 ) , FMIN , FM AX , FLEN,  FTODP,  T I TLE ( 2 ) 

3,  IOCUR,  IPLTYP,  I P LOT , IPRINT,  ItDIT,  NP,  I VLI  ST , NOPP 

4,  I DPP , NV,  ISYM 

E,  ENDPP , I BLOKS ( 1 ) 

DI  MENS  ION  IORLOKl  1 ),  OUMMY(  1 ) , I DPP  ( l ) , IOCUR  ( 1 ) 

EQUIVALENCE  ( DUMMY , L EN P P ) , ( I DBLOK , DUMMY ( 2 ) ) 

C 

C 

C INTERPRET  BLANK  IN  IDPP  AS  A NO-ENTRY 

IF  (.DPP  .EC!.  1H  ) IOPP  = NULL 

C INTERPRET  ('  IN  IOCUR  AS  A NQ-ENTRY.  ENTRY  TU  IOCUR  PERMITTED 

C ONLY  IF  I DP  P WAS  INPUT 

IF  (IOCUR  .EC.  0 .OR.  IDPP  .EQ.  NULL)  IOCUR  = NULL 
LOCI  = LENPP+1 

C SKIP  IF  THERE  ARE  NCT  YET  ANY  PP  BLOCKS  IN  IBLOKS  ARRAY 

IF  (NQLUKS  .EQ.  0)  GO  TO  20 

C CHECK  WHETHER  THIS  BLOCK  HAS  BEEN  INPUT  BEFORE  (SEE  IF 

C INPUT  ID  AND  OCCURANCE  NUMBlR  MATCH  WITH  THOSE  IN  IBLOKS) 

C LOOP  FOR  tACIt  BLOCK  STORtD  IN  IBLOKS 

00  10  1 = 1, Nl  LCjKS 

IF  (IDPP  . EC-  IOPP(LOCl)  .AND.  IOCUR  .EQ.  IUCUR(LOCl))  GO  TC  40 
10  LOCI  = I 0C1  U ENPP 
C 

C NO  MATCH.  THIS  IS  A NEW  BLOCK.  MOVE  IT  IN  BACK  OF  ANY 

C BLOCKS  ALREACY  STOREO 

20  00  30  1 = 1, LENPP 

I OBLCK ( LOCI ) = I OBLOK(  I ) 

30  LOCI  = LOCI  *1 

C BUMP  NUMBER  OF  BLOCKS  STOREO 
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on  n o no  o non  on  on 


NBLQKS  = N BLOKS  *1 
RETURN 

BLOCK  WAS  ALREADY  INPUT.  OVERLAY  OLD  DATA  WITh  THE  NEW  INPUTS 
AO  DO  50  1 = 1 »L  ENPP 

IF  (IDBLUK(I)  .NE.  NULL)  IDBLOK ( L 0C i ) = IDBLJK(I) 

50  LOCI  = LOCI  *1 
RETURN 
END 

SUBROUT INl  INRCOM 

READ  INPUT  PROCESSOR  CONTROL  CARD  COMMAND 

COMMON  //  LENCK,  NBLUKS,  IThCOM,  IDENT,  ITHTYP,  INTYPE 
1.  LSTCHK ( 1 000 ) * LSTSAV( ICCCC) 

DIMENSION  LSTC0M(a),LSTTYP<4) 

DATA  LSTCCM/3H  INP,  3HLIB,  3HEND,  3 HR  UN  / 

DATA  LSTTYP/1H0,  iHS,  1HG,  1HP/ 


READ  COMMAND,  CATA-TYPE,  IDENTIFIER  (IC1.IC2  ARE  COMMAS) 

RE  AD (5, 10)  KOMAND,  IC1,  INTYPE,  IC2, IDENT 
10  FORMAT ( A3 , 3 A 1 , A10) 

WR I TE ( 6 *20 ) KOMANU, IC1,  INTYPE,  IC2, IUENT 
20  FORMAT  I IX, A3, 3*1, A 10 ) 

MATCH  INPUT  COMMAND  WITH  LIST  OF  POSSIBLES,  GET  I THCuM=COMMAND  NUM 
DO  30  IT HCOM= 1, A 

30  IF  IKUMANC  .EG.  LS TCOM ( ITHCOM  ) ) GO  TO  50 
WR I TE ( 5 , AO ) 

<►0  FORMAT  ( <,6H  ILLEGAL  INPJT  PROCESSOR  COMMAND  ON  ABOVE  CAkD) 

CALL  ERKXIT 

SKIP  IF  THIS  COMMANC  DOES  NOT  HAVE  A DATA  TYPE 
50  IF  (ITHCOM  .GT.  2)  GO  TO  80 

MATCH  INPUT  CATA-TYPE  WITH  LIST  OF  POSSIBLES,  GET  I TH  T YP  = T YPE  NUM 
DO  60  IT HT Y P=  1,6 

60  IF  (INTYPE  .EC.  LSTTYPJ  ITHTY P ) ) GO  TO  80 
WRITfc( 6 ,70  ) 

70  FORMAT (32H  ILLEGAL  DATA-TYPE  ON  AROVE  CARD) 

CALL  ERRXIT 

80  RETURN 
END 

SUBROUTINE  INRCAT ( IF  ILE  ) 

READ  NAMELIST  CAT  A FROM  LOGICAL  TAPE  IFILE 

COMMON  /BODY/  I BODY , IPBODY,  B3D0EP , BDODIA,  30DLEN,  BODSPD 
1,  KHSEP2,  RBSTR,  RBLIM 

C 

COMMON  /CONST/  JOK,  JDMODE,  JDTCL,  PI,  NULL,  JDCKL,  JDMFT 
I,  JDCKSV,  JDMSP,  JDEDGE 

C 

COMMON  /CCNTRL/  ICASE,  ICKFlG(2C),  J D I SP , JFFT,  JPOT 
If  NOD  ISP,  NOGRIC 

EQUIVALENCE  ( MODStA, IC<FLG( 1 ) ) , ( MODOBS, ICKFL3 ( 2 ) > 

It  ( MOCBOC,  ICKFLGI 3 ) )t  ( ROCWAK , ICKFLG(A)  ) , ( MODSUP , I C KF LG ( 5 ) ) 

c 

COMMON  / GRID/  OBSDfcP,  NOBS,  DOBS,  OBSMAX,  TABOBS(IOO),  I THOBS 
1»  X,  CX,  XMIN,  NX,  ITHX,  Y,  DY,  YMIN,  NY,  ITHY,  MOJE 1 , MOOEN 

2 f I VAR,  IPRDT,  IPPDTI9),  XPMAX,  YPMAX,  IPPPSD,  IPREOG 

3 * ISPHAS 

C 

COMMON  /OCEAN/  L1BSEA,  RODES,  NK , TABK(IOO),  NZT,  3 KR  A T , OTOEP 
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It  TDEPMX,  T DEP  ( 400  ) * NFL  AG  * SQBV(AOO),  OCNOEP,  RKMAX 

2 1 SCN(AOO),  NKT , IPPVEC 

C 

COMMON  /SUPER/  ISUPR,  SUPTOP,  SUPB3T,  IPSUPR,  SUSTR,  SUSEP2 
It  SUPMID,  SULIM,  SJPDIA,  SUPLEN 

C 

COMMON  /WAKE/  iWAKt,  CwAKR,  CWAKX,  XWAKE,  WAKRAD,  XWNOM 
It  RESLVS,  CWAKM 

C 

COMMON  //  LENCK,  (MBLO<S,  ITHCOM,  IDENT , ITHTYP,  INTYPc 
It  LSTCHK(IOOO),  LSTSAVl 10000) 

COMMON// 

1 LENPP,  PNAME , PMIN,  PMAX,  PLEN,  VNAME , VMIN,  VMAX 

2,  VLEN,  FNAME(2>,  FM  IN , FM  AX,  FLEN,  FTODP,  TI  TLE  ( 2 ) 

3,  IGCUR,  IPLTYP,  IPLOT,  IPRINT,  IfcL'IT,  NP,  IVLIST.  NOPP 

A,  I DPP , NV,  ISYM 

E,  ENDPP,  I BLOKS ( 1 ) 

DIMENSION  I CBLOK  ( „ ),  DJ  MMY  ( 1 ) 

EQUIVALENCE  ( DUMMY , L ENP  P ) , I I CBLQK , DUMMY ( 2 ) ) 

NAMELIST/ OCEAN/  IPRDT , IPPDT,  L IB  SEA , MODES,  NK,  TA3K,  NZT 
It  DKP.AT,  CTCEP,  TDEPMX,  T DEP , NFL  AG,  SQBV,  OCNDEP 
2,  NODISP,  IPPVEC,  R<MAX,  IPREDG 

NAMELIST/SOURCE/  BCCDEP,  BQDD I A,  BQDLtN,  IBODY,  BQDSPD,  1PB0DY 
It  ISUPR,  SUPTOP,  SJPBOT,  IPSUPR,  SUPMID,  SUPOIA,  SUPLEN 
2,  IWAKE,  CWAKR,  CWAKX,  RESLVS,  CWAKM 

N AMEL IST/GKIC/  OBSCEP,  NOHS,  DOBS,  OBSMAX,  TABOBS,  DX,  XMI N 
It  NX,  DY,  NY,  MOD  El , MODEN,  IVAR,  XPMAX,  YPMAX,  NOGRID 
2,  IPPPSD,  YMIN,  ISPHAS 

NAMELIST/PP/  PNAME,  PMIN,  PMAX,  PLEN,  VNAME,  VMIN,  VMAX,  VLE  N 
It  FNAME,  FM  IN,  FM  AX , FLEN,  FTODP,  TITLE,  IOCUR,  IPLTYP 

2,  I PLOT , IPRINT,  I ED  IT,  NOPP,  IDPP,  ISYM 

C 
C 

C GO  READ  DESIREC  TYPE  OF  DATA 

GO  TO  (10, 20, 30, AO),  ITHTYP 
C 

C T Y PEI  — 0 

10  READ( IFILE, OCEAN) 

GO  TO  100 
C 

C TYPE2--S 

20  READ(  IFILF, SOURCE) 

GO  TO  100 
C 

C TYPE  3 — G 

30  READ( IFILE, GRIC) 

GO  TO  100 
C 

C TYPE  A — P 

C INSERT  NO-ENTRY  VALUES  IN  P/P  INPUT  BLOCK 

AO  CO  50  1=1, LENPP 

50  I DBLOK  ( I ) = NULL 
READ( IFILE, PP) 

C MOVE  INPUT  PP  BLOCK  TO  IBLOXS  ARRAY 

CALL  INMVPP 
C 

100  RETURN 
END 

SUBROUTINE  INRSPP 

C RESTORE  PRINT/PLOT  SPECIFICATIONS  FROM  PREVIOUS  CASE 

C 

COMMON  / CCNTRL/  ICASE,  ICKFLG(20),  JOISP,  JFFT,  JPOT 
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1»  NCDISP,  NOGRIC 

EQUIVALENCE  (MODSEA,  IC<FLG(  1 ) ) , ( MO  DOBS,  ICKFLG ( 2 ) ) 

1»  ( MODBOC, ICKFLG( 3 ) ),  ( MODW AK , I CKFLG ( A ) ) , ( MGDSUP , ! C KF  LG ( 5 ) ) 

/FILES/  NTILIB,  MTDL  I 8,  NTPDtF,  TP  1 0 * NTPOAT,  NT  PLOT 
It  IMTDTAB,  NTEVEC,  NTTEMP 

COMMON  //  LBNCK,  NBLOKS,  ITHCDM,  IDtNT,  I THTYP  » INTYPE 
1.  LSTCHKI iOOO) , LSTSAVI 1CCCO) 

COMMON/ / 

1 LFNPP,  PNAME,  PMIN,  PMAX,  PLEN,  VNAME,  VMIN,  VMAX 

2*  VLEN,  FNAMEI2),  FM  IN  » FMAX,  FlEN,  FTODP,  TITLE  ( 2 ) 

3*  I CClJ  Rf  IPLTYP,  I PLOT  , IPRINT,  I i_D  IT,  NP,  I VL I ST , NOPt' 

I DPP,  NV,  ISYM 
E,  ENDPP,  IPLOKS(l) 


IF  { ICASF  .GT.  1 ) GO  TO  10 
NOTHING  TC  KESTORE  ON  FIRST  CASE 

INITIALIZE  LENGTH  OF  SPEC  BLOCK,  NUMBER  OF  BLOCKS 
LLNFP  = LOCFItNDPP)  - LOCF(LENPP) 

NBLGKS  - 0 
RETURN 

10  RLWINU  NTPUEF 

READ(NTPDEF)  NBLOKS, LFNPP 
RETURN  IF  THERE  WERE  NO  SPECS 
IF  (NBLOKS  .LE.  0)  RETURN 

RESTORE  PP  SPECIFICATIONS  FROM  PREVIOUS  CASE 
DO  20  I = i, NBLOKS 
LI  M2  = I *LENPP 
L I Ml  = L I M2  -LENPP  +1 
20  READ(NTPDEF)  ( IBLUKS(J),J  = LIMl,LIM2) 

RETURN 

END 

SUBROUTINE  INRUN1 

CNCE  PER  RUN  INITIALIZATIONS 

COMMON  /CONST/  JDK,  JDMODE,  JCTCL,  PI,  NULL,  JDCKL,  JDMFT 
It  JDCKSV,  JDMSP,  JDEDGE 

COMMON  /FILES/  NTILIB,  NTOLIB,  NTPDEF,  NTPID,  NTPDAT,  NTPLOT 

1,  NTUTAB,  NTEVEC,  NTT  EMP 

COMMON/ PPCOM/ 

1 LENPP,  PNAME,  PMIN,  PMAX,  PLEN,  VNAME,  VMIN,  VMAX 

2,  VLEN,  FN  AME ( 2 ) , FMIN , FMAX,  FLEN,  FTODP , T I TL  E ( 2 ) 

3t  IOCUR,  IPLTYP,  I PLOT , IPRINT,  I ED  I T,  NP,  IVLIST,  NOPP 

4,  I DPP , NV,  ISYM 

E,  ENUPP,  I BLOKS ( 1 ) 


01  MENS  IONS 

K (WAVE  NUMBER  ARRAY) 

JDK  = 100 

MAX  MODE  NUMBER  ( DT  ROJTiNES) 

JOMCDE  = BO 

MAX  MODE  RANGE  FOR  FT  ROUTINES 
JDMFT  = AO 

MAX  MODE  RANGE  FOR  SP  ROUTINES 
JDMSP  = A I 

MAX  NUMBER  OF  ENTRIES  IN  WAVE  FAMILY  EDGE  TABLES 


«**• 

Ay 
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JDEDGE  = 20 

C NUMBER  OF  POINTS  IN  THERMOCL  INE 

JDTCL  = 400 

C 0 1 MENS  I ON  OF  CHECKLIST 

JDCKL  = 1000 

C DIMENSION  OF  CHECKLIST  VARIABLE  SAVE  STORAGE 

JDCKSV  = 10000 
C 

C NO-ENTRY  VALUE  ITU  CHECK  WHETHER  A VARIABLE  WAS  INPUT) 

NULL  = 9HNULL 
C 

PI  = 3 . 14159265359 
C 

C TAPE  UNIT  ASSIGNMENTS 

C INPUT  DATA  LIBRARY 

NT  I LI B = i 

C DISPERS ION  LIBRARY 

NTDLIB  = 2 

C OISPERSION  TABLE  — NOTE  ASSIGNMENTS  FOR  NTDTA3  AND  N T 7 E MP  ARE 

C SWITCHED  EACH  ENTRY  TO  DTCON 

NT DT  AB  = 3 
C TRANSFORMS 

NTT  EMP  = 4 

C ( I NPUT  = 5 » OUT  PUT  = o ) 

C EIGENVECTORS 

NTEVEC  = 7 

C P/P  DEFINITIONS  (INPUT  IMAGE) 

NTPDEF  = 8 
C P/P  DAT  A FIl  E 

NTPDAT  = 9 
C P/P  ID  FILE 

NT  PI D = 10 
C PLOT  OUTPUT 

NT  PLOT  = 80 
C 

C TELL  RUUTINE  SETID  IT  IS  OK  TO  START  A NEW  PP  SET 

IUPP  = 1H 
RETURN 
END 

SUBROUTINE  INSVCK 

C SAVE  THE  VARIABLES  IN  THE  CHECKLIST  IN  ARRAY  LSTSAV 

C 

COMMON  /CONST/  JCK,  JDM  ODE  , JDTCL,  PI,  NULL,  JDCKL,  JDMFT 
1,  JDCKSV,  JDMSP,  JDEDGE 

C 

COMMON  //  LENCK,  NBLOKS,  ITHCOM,  IDENT,  ITHTYP,  INTYPE 
It  LSTCHKI 1000),  LSTSAV ( l COCO) 

DI  MENS  I ON  I BASE!  1) 

C 

c 

C INDEX  TO  CHECKLIST  VARIABLES  STORAGE 

ISAV  = 0 

C LCOP  FOR  EACH  ENTRY  IN  CHECKLIST 

00  20  ITHCK=1, LENCK 

C PICK  UP  DIMENSION,  LOC  OF  NEXT  ENTRY.  MASK  OUT  OTHER  STUFF 

1 DI M = LST  CHK ( IT  HCK ) .AND.  7 777 77777777B 

C MASK  TO  DROP  DIMENSION,  PICK  UP  ADDRESS 

LOC  = I DI M .AND.  777777B 
C CONVERT  ABSOLUTE  ADDRESS  TO  IBASE  INDEX 

LOC  * LOC  -LOC F(  IBASE)  +1 
C SHIFT  OUT  ACCRESS  TO  GET  DIMENSION 

IDIM  = IDIM/10000008 
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c 

c 


c 


c 

c 

c 


1 

j 

c 

c 


c 


c 

c 


SAVE  tACH  WORD 

DU  10  1 = 1,  iCIM 

ISAV  = I S A V +1 

LSTS  AV  ( ISAV)  = IBASEILOL) 

10  LOG  = LOG  +1 
20  CONTINUE 

COMPARE  NUMBER  OF  VARIABLES  SAVED  WITH  DIMENSION  OF  SAVE  ARRAY 
IF  (ISAV  .L£.  JCCKSV)  GO  TO  AO 
W R I T E ( 6 , 3 0 ) ISAV  * J DCKS  V 

30  FORMAT l A 1H  CHECKLIST  VARIABLE  SAVE  STORAGE  E XC EE DED ,2  I 1 0 ) 

CALL  ERRXIT 
AO  RETURN 
END 

SUBKUUT I Nt  INSVPP 

SAVE  PRINT/PLOT  S P EC  I F I CAT I3NS  FOR  THIS  CASE 

COMMON  /FILLS/  NT  IL  IB,  NTDLIB,  NTPDEF  , N TP  I D , NTPDAT,  NT  PLOT 

1,  NTDTAB,  NT  EV  EC,  NTT  EMP 

COMMON  //  LLNLK,  N BLOKS,  ITHCOM,  I Dt.N  T , ITHTYP,  INTYPl 
It  LSTCHK  ( *.000  ) , LSTSAVl  1C000) 

COMMON// 

1 LENPP,  PNAME,  PMIN,  PMAX,  PLEN,  VNAME  , VMIN,  VMA  X 

2,  V L t N , FNAMEl 2 ) , FM  IN  * FM AX , FLEN,  FTODP,  TITLEI2) 

3,  10CUR,  IPLTYP,  I PLOT , IPRINT,  I ED  I T,  NP,  IVLIST,  NOPP 

A,  IDPP,  NV,  ISYM 

E,  ENOFP,  I BLOKS l 1 ) 


REWIND  NTPDEF 

NUMBER  CF  BLOCKS,  LENGTH  OF  EACH 
WRITLINTPCEF)  NBLUKS, LENPP 
IF  ( NBLUKS  .LE.  0)  GO  TO  20 
00  10  I = 1 * NHL  CKS 
LI  M2  = I *LENPP 
LI  Ml  = LI  M2  -LENPP  +1 
10  WRITE(NTPDEF)  (I  BLOKS!  I),I=LIM1,LIM2) 

20  RETURN 
END 

SUBROUTINE  PPCON 
PRINT/PL01  CONTROL 

COMMON  /FILES/  NTILIB,  NTDLI8,  NTPDEF,  NTPID,  NTPDAT,  NTPLOT 
1,  NTDTAB,  NT  EV  EC,  NTT  EMP 

COMMON  //  V L I i>  T ( 20  50),  FL  I ST  ( 20  50  ) , NOPROC.  IPVAL,  NBLOKS 

1,  IPPENC,  JEOIT,  MATCH,  ISKIPP,  L I ML  0 , LIMrII,  PVAL,  LENDAT 

2,  L I MV  1 , LIMVE,  ITH3UT,  HT,  PVALSI1000),  IMAXSI1000) 

3,  VFMAXSI  1000)  , FMINS(ICCO),  VFM1NSI 1CC0) , F I SI  1000) 

A,  SQFIStlOOO),  IPBJFI1C2A),  kANGEP,  FIRSTP,  DELTAP 

5,  FIRSTV,  DELTAV,  FIRSTF,  DEL  TAF 

COMMON  // 

1 LENPP,  PNAME,  PMIN,  PMAX,  PLEN,  VNAME,  VMIN,  VMA X 

2,  VLEN,  FNAMEI2),  FM  IN , FM  AX , FLEN,  FTODP,  TITLEI2) 

3,  ICCUR,  IPLTYP,  I PLOT , IPRINT,  I ED  I T , NP,  IVLIST,  NOPP 

A,  IDPP,  NV,  ISYM 

E,  ENDPP,  IBLUKS(l) 


CALL  TIMLRI13) 

LOAD  ALL  P/P  SPECIFICATIONS  WHICH  WERE  INPUT 
CALL  PPE.PEC 

\ 


' 


if 
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C RETURN  IF  NO  P/P  FOR  THIS  CASE 

IF  (IPPEND  .NE.  0)  GO  TO  AO 

READ  PPFB  FROM  PROGRAM  TAPE,  SET  UP  VLIST  IF  APPROPRIATE 
10  CALL  PPTUEF 

JUMP  TO  TERMINATE  P/P  PROCESSING  FOR  THIS  CASE 
IF  ( IPPEND  .NE.  0)  GO  TO  30 

ENFORCE  INPUT  SPECS  TO  V I ELD  NET  P/P  DEFINITION 
CALL  PPIDEF 

IF  (IPPEND  .NE.  0)  GO  TO  30 

SET  LIMITS,  SCALES,  ETC.  DRAW  AXES  IF  PLOTTING 
CALL  PPSET 

LCOP  FOR  tACH  DATA  RECORD  (EACH  PARAMETER  VALUE)  IN  THIS  PP  SET 
DO  20  1 PV AL  = 1 »NP 

READ  DATA  KECCPH  ANC  DECIDE  WHETHER  TO  PROCESS  IT 
CALL  PPDATA 


SKIP  IF  DATA  IS 

NUT 

TO 

BE 

PROCESSED 

IF 

(NOPROC  .NE. 

0) 

GO 

TO 

20 

PRINT 

IF 

(IPRINT  .NE. 

0 ) 

CALL 

P PR  INT 

PLOT 

IF  ( I PLOT  .NE.  0)  CALL  PPLOT 
20  CONTINUE 

SET  ORIGIN  FOR  NEXT  PLOT.  NOTE  NEW  ORIGIN  EMPTIES  PL  ,T 
BUFFER  WHICH  PERMITS  OVERLAY  OF  BUFFER  AFTER  ANY  PLOT  COMPLETED 
IF  (IPLCT  .NE.  0 ,«ND.  ISKIPP  ,EQ.  0)  CALL  PPLORG 

DO  SUMMARY  PRINT  IF  REQJESTED 

IF  (IPRINT  .GE.  2 .AND.  ISKIPP  ,EU.  0)  CALL  PPSUM 
LOOP  FOR  NEXT  PP  SET 
GO  TO  10 


TERMINATE  PP  PROCESSING  FOR  THIS  CASE 
30  REWIND  NTPID 
REWIND  NTPOAT 
AO  CALL  T I ME  R ( - 13  ) 

RETURN 

END 

SUBROUTINE  PPAXIS(XO,  YO,  LABEL,  LENLAB,  AXLEN,  ROT,  FIRST,  DELTA) 
DRAW  ANC  LABEL  AXES 

NOTE  CALLING  SEO  IS  SAME  AS  CALCOMPS  AXIS  ROUTINE 

ALSO  NOTE  THIS  IS  NOT  AS  GENERAL  AS  AXIS  (AXIS  MAY  REPLACE 

ANY  CALL  TO  PPAXIS  BUT  NOT  VICE-VERSA) 


LENGTH  OF  AXIS  LABEL 
LLAB  = lABS(LENLAB) 

C CHARACTER  SIZE 

HT  = .105 

C DIRECTION  COSINES  OF  AX IS--PRESET  FOR  X AXIS 
CX  = 1. 

CY  - 0. 

C SKIP  IF  THIS  IS  X AXIS 

IF  (LENLAB  .LT.  0)  GO  TO  10 
C Y AXIS 

CX  = 0. 

CY  = 1. 

C LOC  OF  OUTSIDE  OF  TIC  MARK  WRT  INSIDE 

10  DXMC  = CX«(0.)  ♦ CYM-HT/2.) 

DYTIC  = CX  * ( -HT / 2 . ) ♦ CV*( 0.  I 


129 


r 


I 


C LOC  OF  START  OF  SCALE  WRT  INSIDE  OF  TIC  MARK 

DXSCA  = CX*(-8.*HT  + .025  ) + CY*( -10 .*HT- . 025 ) 

DYSCA  = CX*(-1.5*HT)  ♦ CY*(0.) 

C LOC  OF  START  OF  AXIS  NAHE  WR T END  OF  AXIS 

DXNAM  = CX  * ( - 10 . *HT  ) ♦ CY»(-10.«HT) 

CYNAM  = CX  * ( -3  . *HT  ) ♦ CY*(1.5*FT) 

C INCHES  ALONG  AXIS  NEEDED  TO  WRITE  SCALE 

DAMIN  = CX  *(  R . *HT  ) + CY*(  H + .1) 

C CURRENT  POSITION  ALONG  AXIS 

XLOC  = XO 
YLOC  = YO 

C CURRENT  LtNGTH  OF  AXIS 

ALEN  = 0. 

C ROVE  PFN  TC  ORIGIN 

CALL  PLOT ( XO  * YO,  3) 

C 

C LOOP  FOR  EACH  INCH  OF  AXIS— MAX  LENGTH  ICO 

DO  30  I T HT  I C=  1 , 100 
C DRAW  TIC  MARK 

CALL  PLCTIXLOC+DXT IC,  YLOC+DYTIC,  2) 

C SKIP  SCALE  IF  NOT  ENOUGH  ROOM  TO  DRAW  IT 

IF  (ALEN+CARIN  .GT.  AXLEN)  GO  TO  20 
C CONVERT  SCALl  NUMBER  TO  DISPLAY  CODE 

SCALE  = PPBCII  CELT A*AL EN+F  IRST  ) 

C DRAW  IT 

CALL  SYMBCLIXLOC+DXSCA,  YLOC+DYSCA,  HT,  SCALE,  0.,  10) 

C BRING  PEN  (UP)  BACK  TO  INSIDE  TIC 

20  CALL  PLOT  < XLOL , YLOC,  3) 

C GET  AXIS  LENGTH  AT  NEXT  TIC 

ALEN  = AMINKAXLEN,  ALEN+1.) 

C EXTEND  AXIS  TO  NEXT  TIC 

XLCC  = XO  + CX  * AL  EN 
YLOC  = YO  + CY*ALEN 
CALL  PLOT (XLCC,  YLOC,  2 ) 

30  IF  (ALEN  .GE.  AXLEN)  GO  TO  AO 
C 

C DRAW  TIC  AND  SCALE  FOR  END  OF  AXIS 

AO  CALL  PLOT (XLCC+CXT IC,  YLOC+DYTIC,  2) 

SCALE  = PPBCI( DELT  A*Al EN  + F IR  ST ) 

CALL  SYMBOL! XLOC+CXSCA,  YLOC+DYSCA,  HT,  SCALE,  0.,  10) 

C DRAW  NAME  OF  AXIS 

CALL  SYMBLL ( XL 0C+ DXNAM,  YLOC+OYNAM,  HT,  LABEL,  0.,  LLAB) 
C FIND  POSITION  OF  SCALE  VALUE=ZERO  ON  AXIS 
ZLOC  = -FIRST/DELTA 

C SKIP  IF  SCALE=0  IS  OFF  (OR  AT  END)  OF  AXIS 

IF  (ZLOC  .LE.  0.  .OR.  ZLOC  .GE.  ALEN)  GO  TO  50 
C MARK  THE  AXIS  AT  SCALE=0 

ZX  = XO  + CX  *Z LOC 
ZY  = YO  + CY»ZLOC 
CALL  PLOT ( ZX , ZY , 3) 

CALL  PL0T(ZX+CY»HT/2.,  ZY+CX*HT/2.,  2) 

50  RETURN 
END 

FUNCTION  PPBCI(RNUM) 

C CONVERT  RNUM  TO  (MAX)  9 CHARACTER  DISPLAY  CODu 

C 

C 

ANUM  = ABS(RNUM) 

C USE  E FORMAT  FOR  LARGE  NUMBERS 

IF  (ANUM  .GE.  1000C0.)  GO  TO  1C 
C USE  E FORMAT  FOR  SMALL  NUMBERS 

IF  (0.  .LT.  ANUM  .AND.  ANUM  .LT.  .01)  GO  TO  10 


\ 


I 
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c 


c 


c 

c 


c 


c 


c 


c 

c 


c 

c 


c 


c 

c 

c 

c 

c 

c 

c 

c 


c 


USE  I format  for  integers 

INUM  = RNU  M 

IF  ( ABS  (KNUM-FLGAT  ( INUM  )>  .L  T . .C0001)  GO  TO  20 
CHCGSF  BETWEEN  2 F FORMATS  TO  MAINTAIN  3 DIGIT  ACCURACY 
IF  (ANUM  .LT.  10.)  GO  TO  30 
GO  TO  40 


10  ENCCDE(10,15,BCI ) RNUM 
15  FORMAT ( E10 .C ) 

GO  TO  50 

20  ENCU0E(10,25,dCI  ) INUM 
25  FORMAT (110) 

GO  TO  50 

30  ENCCOE ( 10 , 35 , BCI ) RNUM 
35  FORMAT ( F10 .5 ) 

GO  TO  50 

40  ENCL0E(10f45ftiCI  ) RNUM 
45  FORMAT (F10 .2  ) 


50  PPBCI  = BCI 
RETURN 
END 

SUBROUTINE  F PL  AT  A 

READ  NEXT  DATA  RECORD,  CHECK  LIMITS 

COMMON  /FILES/  NTILIB,  NTDLIB,  NTPDEF,  NTPID,  NTPUAT,  NT  PLOT 
1,  NTUTAfi,  NT  EV  EC,  NTT  EMP 

COMMON  //  V L 1ST ( 2050 ) , FLIST<2050),  NOPROC,  IPVAL,  NBLOKS 

1,  IPPENC,  JEDIT,  MATCH,  ISKIPP,  L I ML  0 , LlMHI,  PVAL,  LENDAT 

2,  LIMVl,  LIMVE,  ITH3UT,  FT,  PVALS(IOCC),  FMAXS(IOCO) 

3,  VFMAXS< 1000) , FMINS(ICOO),  VFM  I N S ( 1 CC  0 ) , FIS(IOOO) 

4,  SUFIS(IOOO),  IPB  JF(  1024 ) , RANGEP,  FIRSTP,  DELTAP 

5,  FIRSTV,  DELTAV,  FIRSTF,  DEL  T AF 
COMMON  // 

l LENPP,  PNAME,  PMIN,  PMAX,  PLEN,  VNAME,  VMIN,  VMA X 

2,  VLEN,  FN  AM  E( 2 ) , F M IN,  FM AX,  FLEN,  FTODP,  TITLE(21 

3,  IOCUR,  IPLTYP,  IPLOT,  IPRINT,  IEDIT,  N°,  IVLIST,  MOPP 

4,  I DPP , NV,  ISYM 

E,  END  PP  , I BLOK  S ( 1 ) 


PRESET  FLAG  SC  DATA  READ  HERE  WILL  BE  PROCESSED 
NCPROC  = 0 

TEST  DATA  RECORD  FORMAT 
IF  (IVLIST  .EQ.  3)  GO  TO  10 

VLIST  IS  FIXED.  READ  PARAMETER  VALUE,  LOWER  AND  UPPER 
LIMITS,  FUNCTION  VALUES 

RE AD( NT  PDAT  ) PV AL , L l, L 2, ( FL I ST ( I ) , I =L 1, L 2 ) 

SET  FWA  AND  LW A OF  DATA  TO  BE  PROCESSED.  DATA  MUST  LIE  WITHIN 
(VMI N,  VMAX  ) WINDOW  AND  HAVE  A FUNCTION  VALUE 
LIMVl  = M AXO  ( L I ML  0,  L l ) 

LI  MV  E = M I NO  ( L IMHI.L2) 

SKIP  IF  NO  DATA  ( DONT  TRY  TD  PROCESS  JUST  ONE  POINT) 

IF  (LIMVl  .GE.  LIMVE)  GO  TD  100 
LENDAT  = LIMVE  -LIMVl  +1 
GO  TO  20 
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VLIST  CHANGED  WITH  PARAMETER.  READ  PARAMETER  VALCE , LENGTH 
CF  V/FLIST,  VARIABLES  AND  FUNCTIONS 
10  REAO(NTPDAT)  PV  AL , L IMH  I , ( V L I ST  ( I ) , FL  I ST  ( I) , I =1 , L I MH  I ) 

LIMLO  = 1 

JUMP  IF  THIS  PP  ScT  IS  TO  BE  SKIPPED 
2 0 IF  (IS  KIPP  .N£.  0)  GO  TO  ICC 

JUMP  IF  PARAMETER  VALJE  IS  OUTSIDE  DESIRED  RANGE 
IF  (PV  AL  .LT.  PM  I N .OR.  PV AL  .GT.  PMAX  ) GO  TO  100 
JUMP  IF  STORAGE  LIMIT  WOULD  BE  EXCEEDED 
IF  (ITHOUT  .GE.  1000)  GO  TO  ICO 

IF  A NEW  VLIST  WAS  JUST  P EAD  * FIND  FWA  AND  LWA  OF  DATA  IN 
RANGE  VM1N  TO  VMAX 

IF  (IVIIST  . EQ.  3)  CALL  PPVL IM( NOP  ROC  ) 

JUMP  IF  NL  DATA  IN  THAT  RANGE 
IF  (NOPROC  . NE . 0)  GO  TO  ICC 

BUMP  NUMBER  OF  RECOKOS  (PARAMETER  VALUES)  PROCESSED 
ITHCUT  = ITHOUT  ♦ 1 

SAVE  PARAMETER  VALUE  IN  DISPLAY  CODE 
PV  A LS  ( I T HtUT  ) = PPGCKPVAL) 

RETURN 


00  NOT  PROCESS  THIS  CAT  A RECORD 
100  NOPROC  = 1 
RETURN 
END 

SUBROUTINE  FPIOEF 

OVERLAY  PROGRAM  TAPE  PPFB  WITH  INPUT  PPFB  (IF  ANY) 

COMMON  /CONST/  J UK , JOMOOE,  JOTCL , PI,  NULL,  JDCKL,  JDMFT 
1*  JOCKSV,  JDMSP,  JOEDGE 

COMMON  //  VL  IST( 2050) , FLIST(2050),  NOPROC,  IPVAL,  NBLOKS 

1,  IPPEND,  JEDIT,  MATCH,  ISKIPP,  LIMLO,  LIMHI,  PVAL,  LENDAT 

2,  LIMV1,  LIMVE,  ITHOUT,  FT,  PVALS(IOOC),  FMAXS(IOOO) 

3,  VFMAXS(  1000),  FMINS(IOOO),  VFM  INS(  1COO) , FIS(IOOO) 
SCFIS(lOOO),  I P B J F ( 1 02  A ) , RANGEP,  FIRSTP,  DELTAP 

5,  FIRSTV,  DELTAV,  FIRSTF,  DELTAF 

COMMON  // 

1 LENPP,  PNAME,  PMIN,  PMAX,  PLEN,  VNAME  , VM1N,  VMAX 

2,  VLEN,  FNAMt(  2 ) , FM  IN , FMAX,  FLEN,  FTODP,  T I TLE  ( 2 ) 

3,  IDCUR,  IPLTYP,  IPLOT,  IPRINT,  IEDIT,  NP,  IVLIST,  NOPP 

4,  I DP  P , NV,  I SYM 

E,  ENDPP , I BLOKS ( 1 1 

DIMENSION  IOCUR(l),  I0PP115,  DUMMY  ( 1 ) , IDBLOK(l) 

EQUIVALENCE  ( DUMMY , LEN P P ) , ( I DBLOK , DUMM Y ( 2 ) ) 


MATCH  = 0 

JUMP  IF  NO  PPFBS  WERE  INPUT  (NOMINAL  VALUES  WILL  STAND) 

IF  (NBLOKS  .EC.  0)  GO  TO  80 

SCAN  INPUT  PPFBS  FOR  FOLLOWING  PURPOSES 

1.  TERMINATE  PP  PROCESSOR  IF  EDITING  (IE  PROCESS  ONLY  DATA  FOR 
WHICH  THERE  IS  AN  INPUT  PPFB)  AND  ALL  INPUT  PPFBS  HAVE  BEEN 
DONE 

2.  DECREMENT  OCCURANCE  NUMBER  OF  ALL  INPUT  PPFBS  WHICH  HAVE  AN 
10  THAT  MATCHES  CURRENT  DATA 

3.  CHECK  FOR  AN  INPUT  PPFB  WHICH  APPLIES  TO  THE  CURRENT  DATA 

BY  SETT’NG  MAT CH--B I T 0=M ATCH  WITH  NULL  ID,  BIT  1 =MATCH  WITH 
10,  BIT  2 = M AT CH  WITH  ID+3CCURANCE 
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IF  (JEOIT  .NE.  0)  IPP  END 
LOC  = I 

00  40  ITH8LK= 1, NBLOKS 
LOC  = LOC  ♦ LENPP 
IF  UOCUR(LOC)  . EO . NULL 
IF  (IOPP(LOC)  .EQ.  NULL ) 
IF  (lUPP(LCC)  .NE.  ICPP) 
IF  ( IOCUR(LOC)  .NE.  NULL ) 
PATCH  = MATCH  .OR.  2 


.OR.  IOCUR(LOC)  .ST. 
MATCH  = MATCH  .OR.  1 
GO  TO  4C 
GO  TO  30 


IPPEND  = 


GO  TO  40 

30  IOCURILCC)  = lOCUR(LOC)  -1 

IF  (IOCURILOC)  . EU . 0)  MATCH  = MATCH  .OR.  4 
40  CONTINUE 

IF  (IPPENU  .NE.  0)  RETURN 
C 

C SKIP  IF  NO  INPUT  PPFB  FOR  CURRENT  DATA 

IF  (MATCH  .EC.  0)  GO  TO  80 
C FIND  THE  INPUT  PPFB  WHICH  APPLIES  ^3  THIS  DATA 

LOC  = 1 

DO  50  ITHBLK= 1, NBLOKS 
LOC  = LOC  + LENPP 

IF  (IDPPILOC)  .EQ.  NULL  .AND.  MATCH  .EQ.  1)  SO  TO  60 
IF  (IDPP(LOC)  .NE.  I DPP  ) GO  TO  50 

IF  (IOCURILOC)  .EU.  NULL  .AND.  MATCH  .LT.  h)  SO  TO  60 
IF  (IOCUR(LCC)  .EU.  0)  GO  TO  60 
50  CONTINUE 

C NEVER  FALL  THROUGH  ABOVE  LOUP 

C OVERLAY  PROGRAM  PPFB  WITH  INPUT  PPFB 

60  00  70  l- l, LENPP 

70  IF  ( IDBLOK (l+LOC-i)  .NE.  NULL)  IDBLOK(I)  * IDBLOKI I +L0C-1 ) 

00  RETURN 
END 

SUBROUTINE  PPLORG 

C MOVE  PEN  ORG  TO  ORG  OF  NEXT  PLOT  AXES 

C 

COMMON  / PRTPLT / IPLTON,  XAORG,  YAORG,  XPORG,  YPGRG 
C 

COMMON  //  VL  IS  T < 2050  ) * FLI$T(  2050),  NOPROC,  IPVAL,  NBLOKS 

1,  IPPENC,  JEOIT,  MATCH,  ISKIPP,  LIMLO,  LIMHI,  PVAL,  LENOAT 

2,  LIMVl,  LIMVE,  ITH3UT , HT , PVALS(IOOO),  FMAXS(IOOO) 

3,  VFMAXS(  1000),  FNINS(ICCO),  VFM  INSl  1CCC)  , FIS(IOOO) 

4,  S OF  I S ( 1000  ) , IPBUF(  1024.',  RANGEP,  FIRSTP,  DELTAP 

5,  FIRSTV,  DELTAV,  FIRSTF,  LELTAF 

COMMON  // 

1 LENPP,  PNAME,  PNIN,  P*AX,  PLEN,  VNAME , VMIN,  VMAX 

2,  VLEN,  FN AM E ( 2 ) , F M IN , F AX,  FLEN,  FTOOP,  TITLE12) 

3,  ICCUR,  IPLTYP,  I PLOT  , IPklNT,  I EDI  T,  NP,  IVLIST,  NOPP 

4,  I DPP , NV,  ISYM 

E,  ENDPP,  I BLOKS!  1 ) 

C 

C 

C JUMP  IF  PLOT  JUST  FINISHED  WAS  A MULTI-TRACE  PLOT 

IF  (IPLTYP  .NE.  0)  GO  TO  10 
C RASTER 

CALL  PLCT ( PLEN+4. -XPORG,  -YPORG,  -3) 

GO  TO  20 

C MULTI-TRACE 

10  CALL  PL0TIVLEN+4. -XPORG,  -YPORG,  -3) 

C 

20  XPORG  = 0. 

YPORG  = 0. 

RETURN 
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END 

SUBROUTINE  PPLOT 

C ORAW  THE  PLOT  FOR  THE  NEXT  PARAMETER  VALUE 

C 

COMMON  /PKTPLT/  IPLTON,  XAORG,  YAORG.  XPORG,  YPORG 
C 

COMMON  //  VL 1ST ( 20j0 ),  FLISTI 2050),  N0P10C,  IPVAL,  NBLUKS 

1,  IPPfcNC,  JEOIT,  MATCH,  ISKIPP,  L I ML  0,  LIMHI,  PVAL,  LENDAT 

2,  L I MV  1 , LIMVE,  ITH3UT,  FT,  PVALS(IOOO),  FMAXS(IOCC) 

3,  VFMAXS ( 1 000  I , FMINS(ICCO),  V FM I NS ( 1C00 ) , F I S I 1000) 

A,  S Q F I S ( 1000  ) * IPB  J F(  1 02  A ) , RANGEP,  FIRSTP,  DELTAP 

5,  FIRSTV,  DELTAV,  FIRSTF,  DELTAF 

COMMON  // 

1 LENPP,  P NAME , PMIN,  PMAX,  PLEN,  VNAME,  VMIN,  VMAX 

2,  VLEN,  FN  AM  E ( 2 ) , FM  IN , FM AX,  FLEN,  FTODP,  TITLE  C 2 ) 

3,  IOCUR,  IPLTYP,  I PLOT  * IPRINT,  I ED  I T , NP,  IVLIST,  NOPP 

A,  ICPP,  NV,  ISYM 

E , ENDPP,  I BLOK S ( 1 ) 

C 

C 

C INSERT  SCALING  PARAMETERS  INTO  VARIATE,  FUNCTION  LISTS 

S AV VI  = VLIST ( LIMVC+I) 

SAVV2  = VL  1ST ( L IMVE+2) 

VLISTI LIMVE+I)  = FIRSTV 
VLIST ( LIMVfc+2)  = DELTAV 
FLISTI LIMVE+I)  = FIRSTF 
FLISTI LIMVE+2 ) = DELTAF 
C JUMP  FOR  MULTI-TRACE  PLOT 

IF  (IPLTYP  .NE.  0)  GO  TO  10 
C RASTER  PLOT 

C MOVE  PEN  ORIGIN  TO  ORIGIN  OF  THIS  LINE 

X = (PVAL-FIRSTP)  / DELTAP 
CALL  PLOT  (X-XPORG,  -YPORG,  -3) 

XPORG  = X 
YPORG  = 0. 

C DRAW  THE  LINE 

CALL  LINE(  FL  IS  T ( L IMV  1),  VL  IS  T(  L IMV  1 ) , LENDAT,  1,  C,  0) 

GO  TO  20 
C 

C PRESET  TO  NO  SYMBOLS 

10  LINTYP  = 0 

C IF  SYMBOLS  DESIRED,  PJT  ONE  AT  1ST  AND  LAST  POINT  OF  TRACE 

IF  (ISYM  .NE.  0)  LINTYP  = LENDAT  -1 
C DRAW  THE  TRACE 

CALL  LINE(VLIST(  L IMV  1 ) , FL  IST(  L IMV  1 ),  LENDAT,  1,  LINTYP, ITHOUT-1) 
C JUMP  IF  NOT  LABELING  THE  TRACES 

IF  ( ISYM  .EQ.  0)  GO  TO  20 

C VERTICAL  LOCATION  TO  WRITE  PARAMETER  VALUE  VS.  SYMBOL 

YPOS  = FLEN  - 2 • »HT  * ( ITHOUT+1) 

IF  (YPOS  .LT.  0. ) GO  TO  20 

CALL  SYMBOL(VLEN,  YPOS,  HT,  PV AL S ( I THOUT  ) , 0.,  1 0» 

CALL  SYMBCL(VLEN+11.5*HT,  YP0S+.5*HT,  HT,  ITHOUT-1,  0.,  -1) 

CALL  PLCT( VLEN+10.5«HT,  YPOS,  3) 

CALL  PLOT (VLEN+10.5*HT , YP0S+2.*HT,  2) 

C RESTORE  INOEP.  VARIABLE  VALJES  CL0B3ERED  BY  SCALE  FACTORS 

20  VLIST( LIMVE+1)  = SAVV1 
VLIST  ( LIMVE  + 2)  = SAVV2 
RETURN 
END 

SUBROUTINE  PPRINT 

C PRINT  DATA  FCR  CURRENT  PARAMETER  VALUE 

C 
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COMMON  //  VL  IS T(  2050 ) » FLISTI2050),  NOPROC,  IPVAL,  NBLOKS 

1,  IPPEND,  JEDIT,  MATCH,  ISKIPP,  LIMLO,  LIMHI,  PV4L,  LENDAT 

2,  LIMV1,  LIMVE,  IT H3UT ♦ HT,  PVALS(IOOO),  FMAXS(IOOO) 

3,  VFMAXS(IOOO),  FMINSI10C0),  VFM INSI  1CC0) , FISI1000) 

4,  SOFIS(IOOO),  IPBJF!1024),  RANGE  P » FIRSTP,  DfcLTAP 

5,  FIRSTV,  DELTAV,  FIRSTF,  DELTAF 
COMMON  // 

1 LENPP,  PNAME,  PMIN,  PMAX,  PLfcN,  VNAME » VMIN,  VMA  X 

2,  VLEN,  FNAME(2>,  FM  IN  » FMAX»  FLEN,  FTODP,  TITLEI2) 

3,  IOCUR,  IPLTYP,  IPLOT,  IPRINT,  I EDI T , NP,  IVLIST,  NOPP 

4,  I DPP,  NV,  ISYM 

E , ENDPP,  I BLOKS ( 1 ) 

C 

C 

C SKIP  IF  NOT  PRINTING  SJMMARY 

IF  (IPRINT  .LT.  2)  GO  TO  15 

C COLLECT  AND  SAVE  STATISTICS  FOR  THIS  PARAMETER  VALUE 

C INITIALIZE  INTEGRAL,  SQUARE  INTEGRAL,  AND  LOG  OF  MAX,  MIN 

FI  = 0. 

SUFI  = 0. 

MAX  = LIMV1 

MIN  = LIMV1 

C LOOP  THROUGH  THAT  PART  OF  DATA  BEING  PROCESSED 

LIM  = LIMV1  ♦ 1 
DO  10  I=LIM, LIMVE 

C PICK  UP  FUNCTION  VALUE  TO  AVOID  INDEXING 

F = FL I ST  < I > 

C LOC  OF  MAX,  LCC  OF  MIN 

IF  { FL I ST ( MAX  ) .LT.  F>  MAX  * I 
IF  (FL I ST (MIN)  .GT.  F)  MIN  = I 
HAFDV  * .5  * IVLIST!  D-VLIST!  I-l)  > 

FI  = FI  ♦ ! F + FL 1ST ! 1-1 ) ) * HAFDV 
10  SQF I = SQFI  + ( F*#2+FL  IST(  I-l)**2)  »HAFD  V 
C SAVE  EXTREMA  INFORMATION 

FMAXS(  ITHOUT)  = FL  1ST  I *4  AX  I 
VFMAXSI ITHOUT)  = VLIST(MAX) 

FMINS(  ITHOUT  ) = FLIST(MIN> 

VFMINS < ITHOUT ) = VLIST(MIM) 

C SAVE  INTEGRAL,  SQUARE  INTEGRAL 

FISC  IT HOUT ) = FI 
SQFISI ITHOUT > = SQFI 
C 

C JUMP  IF  NOT  PRINTING  ALL  POINTS 

15  IF  (IPRINT  .NE.  1 .AND.  IPRINT  .NE.  3)  GO  TO  100 
C FIRST  LINE  OF  PAGF 

WRITE (6, 20)  PV  ALS ( ITHO JT ) , PN AM E , T ITL E , IDPP 
20  FORMAT (1H1,A10,1H=,A10,  20X  , 2A 10,  20X , A 10) 

C 2 FORMATS.  JUMP  IF  PRINTING  V AR I ABL E /FUNCT ION 
IF  (IVLIST  .EQ.  3)  GO  TO  60 
C JUST  PRINTING  FUNCTION 

WRITE! 6 ,30 ) FNAME 
30  FORMAT  C 1 H , 2 A10/ ) 

00  50  I1=LIMV1»LIMVE,8 
IE  = MINO! LIMVE, 11+7) 

WRITE! 6,40 ) II, < FL 1ST!  I ), 1=11, IE  > 

40  FORMAT !1H  , I4,8E13.5) 

50  CONTINUE 
GO  TO  100 
C 

60  WR I TE ! 6 ,70  ) VNAME,  FNAME 
70  FORMAT !1H  ,A10,1H  ,2A10/) 

DO  90  U=UMV1,LIMVE,4 
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IF  = MINCH  LIM.'fc,  11  + 3) 

WRITE! 6, 80)  II, (VL  1ST!  I ) , FL  I ST ( I),  1 = 11, IE) 

80  FORMAT ( 1H  , K , A ( Ei A . A, fc 12 . A ) ) 

90  CONTINUE 
C 

100  RETURN 
ENO 

SUBROUTINE  PPSET 

C SCALING,  SETUPS  FOR  THIS  PP  SET.  DRAW  AXES  IF  PLOTTING 

C 

COMMON  /FILES/  NT  I L I 6,  NTDLIB,  NTPDEF,  NITPID,  NTPDAT,  NTPLOT 
1,  NTDTA8,  NT  EV  EC,  NTTEMP 

C 

COMMON  / P RT  PL) / IPLTON,  XAORG,  YAORG,  XPORG,  YPJRG 
C 

COMMON  //  VLISTI2050),  FLISTI2050),  NOPROC,  IPVAL,  NBLOKS 

1,  IPPEND,  JEDIT,  MATCH,  ISKIPP,  L I ML  0 , LIMHI,  PVAL,  LENDAT 

2,  LIMVl,  LlMVc,  ITHDUT,  HT,  PVALS(IOOO),  FMAXS(IOCO) 

3,  VFMAXS ( 1000)  , FM  INS ( 1C  00 ) , V FM I NS ( ICC  0 ) , FIS(ICOO) 

A,  SOFIS(IOOO),  IPBJFI 102A),  KANGEP,  FIRSTP,  DELTAP 

5,  FIRSTV,  DELTAV,  FIRSTF,  DEL  TAF 

COMMON  // 

1 LENPP,  PNAME,  PMIN,  PMAX,  PLEN,  VNAME,  VMIN,  VMAX 

2,  VLEN,  FNAMEI2),  FM IN , FM AX , FLEN,  FTODP,  TITLEI2) 

3,  IOCUR,  IPLTYP,  I PLOT , IPRINT,  ItDIT,  NP,  IVLIST,  NOPP 

A,  I DPP,  NV,  ISYM 

E,  ENDPP,  I BLOKS ( 1 ) 

C 

C 

C PRESET  TO  PROCESS  TFIS  PP  SET 

ISKIPP  = 0 

C INITIALIZE  COUNT  OF  NUMBER  OF  RECORDS  OUTPUT 

ITHOUT  = 0 

C JUMP  IF  NOTHING  WOULD  BE  ACCOMPLISHED  3Y  PROCESSING  THIS  DATA 

IF  ('PRINT  .EG.  0 .AND.  IPLOT  .EO.  0)  GO  TO  200 
C JUMP  1 ECITING  IS  CN  ( PP  ONLY  DATA  FOR  WHICH  A PPFB  WAS  INPUT) 

C AND  NO  PPFB  WAS  I.mPUT 

IF  (JtDIT  .NE.  0 .AND.  MATCH  .EO.  0)  GO  TO  200 
C 

C SKI P IF  VLIST  IS  NOT  FIXED 

IF  (IVLIST  .GT.  2)  GO  TO  AO 

C FIND  FW  A AND  L W A OF  CATA  WITHIN  RANGE  VMIN  TO  VMAX 

CALL  PPVLIMt I i K I PP) 

LI MLO  = L l MV  1 
LIMHI  = LIMVE 

C JUMP  IF  NO  DATA  WITHIN  THAT  RANGE 

IF  (ISKIPP  .Nt.  0)  GO  TU  200 
C SKI P I F NCT  PRINT  ING 

IF  (IPRINT  .NE.  1 .AND.  IPRINT  .NE.  3)  GO  TO  AO 
C PRINT  THE  LIST  OF  INDEPENDENT  VARIABLE  VALUES 

WR  I TE ( 6 , 10  ) TITLE, IDPP, VNAME 

10  FORMAT 36X , 2A 10, 20X , A 10/ 1H  ,A10/) 

DO  30  1 1 = L I MV  1, L I MV  E, 6 

IE  = MI N0( L IMV  E,  1 1+7  ) 

WRITE (6, 20)  1 1, (VL  ISTC  I ), 1=1  1,  IE) 

20  FORMAT ( 1H  , IA,8E13  .5  ) 

30  CONTINUE 

c C ) 

C SKIP  IF  NCT  PLOTTING  THIS  DATA 

AO  IF  ( I PLOT  .EC.  0)  GO  TO  100 
C CHARACTER  HEIGHT  IN  INCHES 
HT  = .105 
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C SKIP  IP  PLOTTING  HAS  ALREAOY  BEEN  OPENED 

IF  (IPLTON  .NE.  01  GO  TO  50 
C CNCE  PER  RUN  INITIALIZATIONS 

CALL  PLOTS!  I PtSU  F,  1024,  NTPLOT  ) 

C SHOW  PLOTTING  HAS  BEEN  INITIATED 

IPLTON  = 1 

LOCATION  OF  ORIGIN  OF  AXES  (IE  LOWER  LEFT  CORNER  OF  PLOT) 

WRT  LL  CORNER  OF  PAGE 
XAORG  * 0 . 

YAGRG  = b.*HT 
WOVE  PEN  CRG  TO  AXES  3RG 
CALL  PLOT (XAORG,  YAORG,  -3) 

LCC  OF  PEN  CRG  WRT  AXES  ORG 
XPORG  = 0. 

YPORG  = 0. 

SET  SCALING  FOR  INDEPENDENT  VARIABLE 
50  FIRSTV  = VNIN 

OELTAV  = (VMAX-VMIN)/VLEN 
JUMP  FOR  MULTI-TRACE  PLOT 
IF  (IPLTYP  .Nt.  0)  GO  TO  60 
RASTER 

IF  (PMAX  .NE.  PM  IN ) G3  TO  55 

RASTER  PLOT  WILL  BLOW.  SWITCH  TO  MULTI-TRACE 
IPLTYP  = I 
GO  TO  SO 

PARAMETER  SCALING 
55  FIRSTP  = PM  I N 

DELTAP  = ( PMAX-PMINJ/PLEN 
FUNCTION  SCALING 
FIRSTF  = 0. 

IF  ( FT  OOP  .NE.  0.  .AND.  NP  .GT.  I)  FLE  N=F  TCOP»  PLE  N/F  LOAT ( NP-l ) 

1 *R ANGEP / < PMAX- PMI N) 

DONT  EVER  LET  THE  LENGTH  JF  THE  FUNCTION  AXIS  EXCfcED  THE  PLOT  SIZE 
IF  (ABS(FLFN)  .GT . ABS(PLEN))  FLEN  = SIGN ( PLE N, FLE N) 

ABSMXF  = AMAXK  A8S(  FMAX  ),  ABS(FMINI) 

OELTAF  = ABSMXF/ FLEN 
IF  (FLEN  .GT.  0.)  GO  TO  70 

POSITIVE  DIRECTION  FOR  F OPPOSITE  FROM  USUAL.  ADJUST  FOR 
DRAWING  AXIS 
FLEN  = -FLEN 
GO  TO  70 

C 

C SCALE  FOR  M.T . PLOT 

60  FIRSTF  = FMIN 

OELTAF  = (FMAX -FMIN  )/FlEN 
C 

C DRAW  PLOT  TITLE 

70  IF  (TITLE!  I)  . NE.  IH  ) CALL  SYMBOL  4 0.,  -YAORG,  HT,  TITLE,  0.,  20) 

C SKIP  FOR  M.T.  PL 01 

IF  (IPLTYP  .NE.  0)  GO  TO  80 
C RASTER.  DRAW  F AXIS 

CALL  PPAXIS(0.,  -3.«HT,  FNANE,  -20,  FLEN,  0.,  FIRSTF,  DELTAF) 

C DRAW  P AXIS,  THEN  VARIABLE  AXIS 

CALL  PPAX  IS (0. , 0.,  PNAME,  -10,  PLEN,  0.,  FIRSTP,  DELTAP) 

CALL  PPAX I S ( 0. , 0.,  VNANE,  10,  VLEN,  90.,  FIRSTV,  DELTAV) 

GO  TO  90 

C 

C MULTI-TRACE.  DRAW  V AXIS,  THEN  FUNCTION  AXIS 

80  CALL  PPAX I S ( 0. , 0.,  VNANE,  -10,  VLEN,  0.,  FIRSTV,  DELTAV) 

CALL  PPAXIS(0..  0.,  FNANE,  20,  FLEN.  90.,  FIRSTF,  DELTAF) 

C SKIP  IF  NCT  LABELING  EACH  TRACE 
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IF  (ISYM  .EC.  0)  GO  TO  90 
DRAW  PARAMETER-KEY  HEADER 
CALL  SYMBCL(VLEN,  FLEN,  HT  , PNAME,  0., 
CALL  SYMB0L(VLEN+11.*HT,  FLEN,  HT,  3HS 
CALL  PLCT (VLEN+14. *HT , FLEN-  .5*HT,  3) 
CALL  PLOTIVLEN,  FLEN-.5»HT,  2) 

CALL  PLOT ( VL  EN* 10 . 5«  HT , FLEN+HT,  3) 
CALL  PLOT ( VLEN  + 10 . 5*HT , FL  EN-2 .»HT»  2) 
CONTINUE 
RETURN 


0.,  10) 
3HSYM,  0., 
3) 


DO  NOT  PROCESS  THIS  PP  SET 
200  ISKIPP  = 1 
RETURN 
END 

SUBROUTINE  PPSPEC 

READ  ALL  THE  PP  SPECIFICATIONS  WHICH  WERE  INPUT  FOR  THIS  CASE 


COMMON  /files/  ntilib,  ntdlib,  ntpdef,  ntpid,  NTPDAT,  NT  plot 
1,  NTCTAB,  NTEVEC,  NTTEMP 


COMMON  //  VL IS T ( 20  50),  FLISTI  2050),  NDPROC,  IPVAL,  NBLOKS 

1,  IPPEND,  JEDIT,  MATCH,  ISKIPP,-  LIMLO,  LIMHI,  PVAL,  LENDAT 

2,  IIMV1,  LIMVE,  ITHOUT,  HT,  PVALS(IOOO),  FMAXS(IOOO) 

3,  VFMAXS  ( 1000  ) , FMINS(IOCO),  VFMINSl  1CCC) , FIS(IOOO) 

9,  SQF IS ( 1000 ) , IPBUFI 1024) , RANGEP,  FIRSTP,  DELTAP 

5,  FIRSTV,  DELTAV,  FIRSTF,  DELTAF 

COMMON  // 

1 LENPP,  PNAME,  PMIN,  PMAX,  PLEN,  VNAME , VMIN,  VMAX 

2,  VLEN,  FNAMEI2),  FMIN,  FMAX,  FLEN,  FTODP , TITLEI2) 

3,  IOCUR,  IPLTYP,  I PLOT , IPRINT,  I EDI T , NP , IVLIST,  NOPP 

A,  ICPP,  NV,  ISYM 

E,  ENDPP,  I BLOKS ( 1 ) 

D I MENS  ION  I EDIT! 1),N0PP( 1 ) , I DPP ( 1 ) , I OCUR ( 1 ) 


IPPEND  = 0 
JEDIT  = 0 

LENPP  = LOCF ( ENDPP ) - LOCF(LENPP) 

REWIND  NTPDEF 

NUMBER  OF  BLOCKS  ANC  LENGTH  OF  EACH 
RE AD( NT  PDEF  f NBLOK $,  L E N BLK 
IF  (NBLOKS  .EC.  0)  GO  TO  50 
IF  (LENBLK  .EQ.  LENPP)  GO  TO  20 
WRI TE ( 6 , 10 ) LENPP, LENBLK 

10  FORMAT  ( A9H  PP  DEFINITION  FILE  FORMAT  INCONSISTENT  WITH  PROG 
I ,6H  SPECS, 2110) 

CALL  ERRXIT 
READ  ALL  INPUT  BLOCKS 
20  LIM1  - 1 

DO  30  ITHBLK* 1, NBLOKS 

LI  M2  = LIM1  +LENPP  -1 

READ(NTPDEF)  ( I BLOKS  C I ) , I-L  INI, LIM2) 

30  LIM1  * LIM1  + LENPP 

I EDIT--  0=P/P  ALL  DATA  WRITTEN,  1*P/P  ONLY  DATA  FOR  WHICH 
THERE  IS  AH  INPUT  BLOC<.  SET  JEDIT=l  IF  ANY  BLOCK  SHOWS  IEDIT=1 
NOPP—  0 = REW INC  DATA,  10  FILES  ANO  PROCEED  TO  P/P,  l=NO  REWIND, 

NO  P/P. 

LOC  = 1 

00  AO  ITHBLK* 1, NBLOKS 

LOC  = LOC  ♦ LENPP 

IF  ( NOPP ( LOC ) .EQ.  1)  GO  TO  60 


- s*. 


\ 


( 


40  IF  ( I EDIT ( LOC ) .EC.  1)  JFCIT  = 1 
50  REWIND  NTPID 
REWIND  NT  PD AT 
RETURN 


C 


u 

C 


c 

c 


c 


c 


c 

c 

c 


c 


60  IPPEND  = I 
RETURN 
END 

SUBROUTINE  FPSUM 
PRINT  SUMMARY  DATA 

COMMON  //  /LISTI2050),  FL I ST ( 2050 ) » NOPROC,  1PVAL,  NBLOKS 

1,  IPPENC,  J EC  IT , MATCH,  ISKIPP,  LIMLO,  LIMHI,  PVAL,  LENDAT 

2,  LIMV1,  LIMVE,  ITH3UT,  HT , P/ALSI10C0),  FMAXS(IOOO) 

3,  VFMAXS ( 1000  ) , FMINS(ICCC),  VFM I NS ( 1CCC) » FIS(ICOO) 

4,  SQFIS(iOOO),  IPBJF! 1024 ) , RANGEP,  F1RSTP,  DELTAP 

5,  F1RSTV,  CELTAV,  FIRCTF,  DELTAF 
COMMON  // 

I LirNPP,  PNAMu,  PMIN,  PM  AX,  PL  EM , VNAME  , VMIN,  VMAX 

2,  VLtN,  FNAMEI2),  FM  IN , FMAX,  FLEN,  FTODP , TITLE ( 2 ) 

3,  I CCU  R , IPLTYP,  I PLOT  , IPR1NT,  IED1T,  NP , IVLIST*  NOPP 

4,  I DPP , NV,  I SYM 

E,  ENDPP,  I BLOKS!  1) 


WR I T E ( 6 , 10  ) FN AME, T ITL E,  IDPP 
10  FORMAT  (10H1FUNCT  ION=,  2A10,  16X,2A1C,20X,A1C) 

WR I T E ( 6 , 20 ) VN  AME  » VN  AME » PN AM  E 
20  FORMAT ( 34H0  VALUE  OF  MAXIMUM  OF  ,A10,6X 

1,  14HMINIMUM  Or  , A 10, 2 OX , 6HSQ UAR E / , A 1 0 , 3 X , 8HF UN. TI  ON 

2,  6 X * 6 HOF  MAX, lOX.BHFUNCi  I0N,6X,bH0r  M I N , 1 1 X , 8HI NTE GR AL 

3,  5X ,8H INT  fcGR AL ) 

WRITE!  6 ,30  ) { I , PV  ALS!  I ) , FM  AX  S(  I ),  VFMAXS!  I ) » FMI  N S ( I ) * VF MI  NS ( I ) , 

1 F IS ( I ) , SO  F I S ( I), 1=1, 1TH0UT) 

30  FORM  AT ( 1H  , 14 , A10 , 4 E 15 . 6, E 15 . 4 , E 1 3 .4 ) 

RETURN 

END 

SUBROUTINE  PPTDEF 

READ  PPFB  FCR  NEXT  PP  DATA  SET  FROM  PROGRAM  TAPE, 

SET  UP  VLIST  IF  APPROPRIATE 

COMMON  /FILES/  NTILIB,  NTDLIB,  NTPDEF,  NTPID,  NT  PD A T , NTPLOT 
1,  NT  DT  AB  , NTEVEC,  NTT  EMP 

COMMON  //  V L IS  T ( 20  50 ) , FL I ST ( 2050 ) , NOPROC,  IPVAL,  NBLOKS 

1,  IPPEND,  JEDIT,  MATCH,  ISKIPP,  LIMLO,  LIMHI,  PVAL,  LENDAT 

2,  LI  MV  1 , LIMVE,  ITHOUT,  FT,  PVALS(IOOO),  FMAXSI  10C0) 

3,  VFMAXS!  1000),  FMINS(IOOO),  VFM  IN  S ( 1 COO ) , F I S(  1000) 

4,  SCFIS!  1000),  IPB  JF(  1024  ) , RANGEP,  FHSTP,  DEL  TAP 

5,  FIRSTV,  DELTAV,  FIRSTF,  DELTAF 

COMMON  // 

1 LtNPP,  PN AME,  PMIN,  PMAX,  PLEN,  VNAME  , VMIN,  VMAX 

2,  aCN,  FN  AM  E(  2 ) , FM  IN , FM  AX,  FLEN,  FTODP,  TITLEI2) 

3,  IUCUft,  IPLTYP,  I PLOT , - IPR  INT,  IEDIT,  NP , IVLIST,  NQPP 

4,  IDPP,  NV,  ISYM 

E,  ENDPP,  IBLOKS!  1) 

DI MENS  I CN  IDBLCK(  1 ), DUMMY!  1) 

EQUIVALENCE  (DUMMY, LENPP), ( I DBLOK, DUMMY ( 2 ) ) 


C 

c 
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C READ  IN  PPFB  FOR  NEXT  PP  FROM  PROGRAM  TAPE 

READ(NTPIC)  LEN,  ( IOBLQM  I),I  = 1,LEN) 

IF  ( EOF, NT  P I D I 10,20 

C EOF  ENCOUNTERED,  TERMINATE  PP  PROCESSOR 
10  IPPEND  = 1 
RETURN 

C THERE  IS  ANCThER  PP  SET.  SET  FLAG  TO  CONTINUE  PROCESSING 

20  IPPEND  = 0 

C SET  ACTUAL  RANGE  OF  PARAMETER  (RANGE  TO  PP  MAY  DIFFER) 

RANGEP  = PM AX  -PM  IN 

C SET  UP  LIST  OF  INDEPENDENT  VARIABLE  VALUES 

GO  TO  (30,50,60), IVLIST 

C LIST  OF  VALUES  IS  SAME  FOR  EACH  PARAMETER  VALUE  AND  IS 

C EQUAL  INCREMENT  FROM  VMIN  TO  VMAX 

30  OV  = (VMAX-VMIN)  / FLOAT(NV-I) 

VLIST(l)  = V PI N 
CO  AO  1=1, NV 

AO  VLIST(I)  = VLIST(I-l)  ♦ DV 
GO  TO  55 

C LIST  OF  VALUES  IS  SAME  FOR  EACH  PARAMETER  VALUE 

C SPACING  IS  ARBITRARY 

50  READ(NTPIC)  ( V L 1ST  ( I ) , I = I,  NV  ) 

C SET  Fw A AND  LW A OF  VLIST 

55  LIMLO  = 1 
LIMHI  = NV 
RETURN 

C VLIST  VARIES  WITH  PARAMETER  VALUES  AND  IS  ON  PP  DATA  FILE 

C ALONG  WITH  FUNCTIUN  VALUES 

SO  RETURN 
END 

SUBROUTINE  FPV L IM( NOCAT  A ) 

C FIND  FW A AND  LW A OF  DATA  IN  RANGE  VMIN  TO  VMAX 

C 

COMMON  //  VLIST! 2050 ),  FLIST(2050),  NOPROC,  IPVAL,  NBLCKS 

1,  IPPEND,  JEDIT,  MATCH,  ISKIPP,  LIMLO,  LIMHI,  PVAL,  LENDAT 

2,  LIMV1,  LIMVE,  ITHOUT,  HT,  PVALS(IOOO),  FMAXS(IOOO) 

3,  VFMaXS! 1000),  FMINS(ICCO),  VFM IMS! ICCO) , FIS(IOOO) 

4,  SQFISI  1000),  IPBJF(1024>,  RANGEP,  FIRSTP,  DELTAP 

5,  FIRSTV,  DELTAV,  FIRSTF,  DEL  T AF 

COMMON  // 

1 LENPP,  PNAMt',  PM  I N,  PMAX,  PLEN,  VNAME , VMIN,  VMAX 

2,  VLEN,  FNAME( 2 ) , FM  IN , FM  AX,  FLEN,  FTODP , T 1 TLE ( 2 ) 

3,  I CCU  R , IPLTYP,  I PLOT  , IPRINT,  I ED  I T , NP  , IVLIST,  NOPP 

4,  I DPP , NV,  ISYM 

E,  ENDPP,  IBLOKS(l) 

C 

C 

C JUMP  IF  VARIABLE  DECREASES 

IF  (VLIST(LIMHI)  .LT.  VLIST!  D)  GO  TO  60 
DO  30  L 1 MV  1* 1 ,L IMH I 

30  IF  (VMIN  .LE.  VL  IST( L IMV 1 » ) GO  TO  40 
GO  TO  110 

40  DU  50  1=1, LIMHI 

LIMVE  = L IMH I- I ♦! 

50  IF  (VMAX  .GE.  VL  1ST ( L IMV E ) ) GO  TO  100 
GO  TO  110 
C 

60  DO  70  L I MV  1= 1 , L IMH I 

70  IF  (VMAX  .GE.  VLIST(LIMVI))  GO  TO  80 
GO  TO  110 

80  DO  90  1=1, LIMHI 

LIMVE  = LIMHI-m 
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40  IF  ( I EDI T ? LOC ) • EU . I)  JECIT  = 
50  REWIND  NTPID 
REWIND  NTPDAT 
RETURN 


C 


C 

c 


c 

c 


c 


c 


c 

c 

c 


c 


60  IPPENO  = 1 
RETURN 
END 

SUBROUTINE  FPSUM 
PRINT  SUMMARY  DATA 

COMMON  //  VLISTI2050),  TL 1ST (2050  1*  NOPRQC,  IPVAL*  NHLUKS 

1,  IPPfcNC,  JECIT,  MATCH,  ISKIPP,  LIMLU,  L » MH I , PVAL,  LEND  A T 

2,  LIMVI,  LIMYE,  ITH3UT,  HT,  PVALSIIOOO),  FMAXSUOOO) 

?.,  VFMAXSI  1000),  FNINSI1CCC),  VFNINSl  ICCCI  , FIS(ICOO) 

S;  SQF  IS  ( 1000  ) , I PH  J F(  1 01 4 I , RANGEP,  F1RSTP,  DEL  TAP 

5,  F1RSTV,  CElTAv,  flRSTF,  DtLTAF 

COMMON  // 

1 LENPP*  PNAMc,  PM  I N,  PMAX,  PL  EM , VMAME , VMIN,  VMAX 

2,  VLEN*  FNAMEI2),  FMIN,  FMAX,  FLEN,  FTODP,  TITLE  1 2 ) 

3,  I CCU  R , 1PLTYP,  I PLOT  , IPRINT,  I ED  I T , NP,  1VLIST,  NOPP 

4,  I DPP,  NV  , ISYM 

E,  ENDPP,  I BLOKS ( li 


WR  IT  E ( 6 , 10  ) FNAME,  TITLE,  IOPP 
10  FORMAT ( 10 HI FUNCT ION=, 2A10, 16X, 2A1C,20X,A1C) 

WRITE ( 6 ,20 ) VNAME, VNAME, PNAME 
20  FORMAT ( J4H0  VALUE  OF  MAXIMUM  OF  ,A10,6X 

1,  14HM1NIMUM  OF  , A 10, 2 OX , 6HSQUARE / 7X, A 1 0 , 3 X , 8HF UNO TI ON 

2,  6 X , 6H0F  MAX, 10X,8H FUNCT  I0N,6X,bH0F  M I N , 1 1 X , 8HI NTE GR AL 

3,  5 X , 8H  I NT  E GR  AL  ) 

WRITE  (6 ,30)  ( I , PV  ALSII) , F*  AXSI  I ),  VFMAXSI  I ) , FMI  N SI  I ) , VF  MI  NS  ( I ) » 
1 FIS ( I ) , SO  F I SI  I),  1=1,  ITHDUT) 

30  FORMAT  I 1H  , 14 , A 10 , 4 E 15 . 6,  E 15 . 4,  E 1 3 .4  ) 

RETURN 

END 

SUBROUTINE  PPTDEF 

READ  PPFB  FCR  NEXT  PP  DATA  SET  FROM  PROGRAM  TAPE, 

SET  UP  V L 1ST  IF  APPROPRIATE 

COMMON  /FILES/  NTILIB,  NTDLIB,  NTPDEF,  NTPID,  NTPDAT,  NTPLOT 
1,  NTDTAB,  NT  EV  EC,  NTT  EMP 

COMMON  //  VL  IS  T I 2050  ),  FLISTI2050),  N0P10C,  IPVAL,  NBLOKS 

1,  IPPENU,  JEDIT,  MATCH,  ISKIPP,  LIMLO,  LIMHI,  PVAL,  LENDAT 

2,  LIMVI,  LIMVE,  ITHOUT,  FT,  PVALSIIOOO),  FMAXSI  10C0) 

3,  VFMAXS  ( 1000),  FMINS(IOOO),  VFM  IN  S ( 1 COO)  , FI  SI  1000) 

4,  SCFISI  1000  ),  IPBJFI  1024  ) , RANGEP,  FIRSTP,  DELTAP 

5,  FIRSTV,  DELTAV,  FIRSTF,  DELTAF 

COMMON  // 

1 LENPP,  PNAME,  PMIN,  PMAX,  PLEN,  VNAME,  VMIN,  VMAX 

2,  VLEN,  FNAMEI2),  FMIN,  FMAX,  FLEN,  FTODP,  TITLEI2) 

3,  I GCUR » IPLTYP,  I PLOT , IPRINT,  I ED  I T , NP,  1VLIST,  NOPP 

4,  I DP  P , NV,  ISYM 

E,  ENDPP,  IBLOKSI  1) 

01  MENS  I GN  IDBLCKI  1 ), OJMMYI  1) 

EQUIVALENCE  (DUMMY, LENPP), I I DBLOK, DUMMY!  2)  ) 


C 

c 
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C READ  IN  PPFH  FOR  NEXT  PP  FROM  PROGRAM  TAPE 

KfcAlMNT  PI  L)  LEN,  ( ID0L3<(  I ),  I =1,  L EN  ) 

IF  ( EOF , NT  P I D ) 10,20 

C EOF  ENCOUNTERED,  TERMINATE  PP  PROCESSOR 

10  IPPEND  = 1 
RETURN 

C THERE  IS  ANOTHER  PP  SET.  SET  FLAG  TO  CONTINUE  PROCESSING 

20  IPPEND  = 0 

C SET  ACTUAL  RANGE  OF  PARAMETER  (RANGE  TO  PP  MAY  DIFFER) 

RANGEP  = PM AX  -PMIN 

C SET  UP  LIST  OF  INDEPENDENT  VARIABLE  VALUES 

GO  TO  (30 ,50,60)  , IVLIST 

C LIST  OF  VALUES  IS  SAME  FOR  EACH  PARAMETER  VALUE  AND  IS 

C EQUAL  INCREMENT  FROM  VMIN  TO  VMAX 

30  OV  = (VMAX-VMIN)  / FLOAT(NV-l) 

VLIST(l)  = VMIN 
CO  AO  I = 2 , NV 

AO  VL  I ST ( I ) = VL  1ST ( 1-1 ) + DV 

GO  TO  55 

LIST  OF  VALUES  IS  SAME  FOR  EACH  PARAMETER  VALUE 
SPACING  IS  ARBITRARY 
50  RE  AD ( NT  P I C ) ( V L I S T ( I ) , I = 1,  N V ) 

SET  Fw  A ANC  LW A OF  VLIST 
55  LIMLO  = 1 
LIMHI  = NV 
RETURN 

VLIST  VARIES  WITH  PARAMETER  VALUES  AND  IS  ON  PP  DATA  FILE 
ALONG  WITH  FUNCTIUN  VALUES 
60  RETURN 
END 

SUBROUTINE  F PV  L I M ( NOCAT  A ) 

FIND  FW  A AND  LW  A OF  CATA  IN  RANGE  VMIN  TO  VMAX 

COMMON  //  VLIST ( 2050 ) , FLIST(2050),  NOPRDC,  IPVAL,  NBLDKS 

1,  IPPENC,  JEDIT,  MATCH,  ISKIPP,  LIMLO,  LIMril,  PVAL,  LENDAT 

2,  LIMV1,  LIMVE,  ITHOUT,  HT,  PVALS(IOOO),  FMAXS(IOOO) 

3,  VFMAXS< 1000),  FMINS(ICCO),  VFM INS( 1CC0) , FIS(IOOO) 

SQF  IS  ( 1000  ) , IPBJF(  1024  ) , RANGEP,  FIRSTP,  DELTAP 

5,  FIRSTV,  CELTAV,  FIRSTF,  DELTAF 

COMMON  // 

1 LENPP,  PNAME,  PMIN,  PMAX,  PLEN,  VNAME , VMIN,  VMAX 

2,  VLEN,  FN  AM  E(  2 ) , FM  IN , FM  AX,  FLEN,  FTODP  , TITLEI2) 

3,  I CCU  R,  IPLTYP,  I PLOT  , IP  R IN*  1 , I ED  I T , NP  , IVLIST,  NDPP 

<►,  I DPP , NV,  ISYM 

E,  ENDPP,  I BLOKS ( 1 ) 


JUMP  IF  VARIABLE  DECREASES 

IF  (VLIST  (LIMH I ) .LT.  VLIST(D)  GO  TO  60 

00  30  L I MV  1* 1 , L IMH I 

30  IF  (VMIN  .LE.  VLIST(LIMVI)  ) GO  TO  <*0 
GO  TO  110 

<V0  DU  50  1=  1 , L IMHI 

LIMVE  = L IMHI- 1+1 

50  IF  (VMAX  .GE.  V L IS T ( L I M V E ) ) GO  TO  100 
GO  TO  110 

60  00  70  L I MV  1=  1 , L IMH  I 

70  IF  (VMAX  .GE.  V L IS T ( L I MV  1 ) ) GO  TO  80 
GO  TO  110 

80  DO  90  I* 1 , L IMHI 
LIMVE  = LIMHI-U1 
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90  IF  (VMIN  .LE.  VL  1ST!  L I MVE  ) ) GO  TO  100 
GO  TC  110 

AMOUNT  OF  C/'T  A TO  BE  PROCESSED 
100  LENDAT  = L IMVE-L  IMV 1 + 1 

JUMP  IF  NO  DA1A.  ALSO  DONT  TRY  TO  PROCESS  JUST  1 DATA  POINT 
IF  (LENDAT  .LE.  1)  GO  TO  110 
NODATA  = 0 
RETURN 

NO  DATA  WITHIN  SPECIFIED  RANGE  VMIN  TO  VMAX 
110  NOOAT  A = L 
RETURN 
END 

SUBRCUT INl  SPCCN 
STATIONARY  PHASE  CONTROL 

COMMON  /BODY/  IBOOY,  IPBODY,  BODDEP,  BODDIA,  BODLEN,  BODSPD 
1,  RBSLPE,  RBSTR,  RBLIM 

COMMON  /GRID/  OBSOEP,  NOBS,  DORS,  OBSMAX,  TABOBSI1CO),  IThOBS 

1,  X,  CX,  X M I N » NX,  ITHX,  Y,  DY , YMIN,  NY,  ITHY,  MODE1,  MOOEN 

2,  IVAR,  IPRDT,  IPPDTI9),  XPMAX,  YPMAX , IPPPSD,  IPREDG 

3,  ISPHAS 

COMMON  /SUPER/  ISUPR,  SJPTOP,  SUPBOT,  IPSUPR,  SUSTR,  SUSEP2 
1,  SUPMID,  SULIM,  SUPDIA,  SUPLEN 

COMMON  /WAKE/  IWAKE,  CW  AKR , CWAKX,  XWAKE , WAKRAD,  XWNOM 
1,  RESLVS,  CW  ARM 

COMPLEX  XUEP,  FSRC 

COMMON  //  RK,  EVAL,  DLDK,  D2L,  PSIO,  DPSIO,  DPSIB,  WAKI  , SIJPT 

1,  YX,  03L,  XI,  ETA,  INRANG,  MODE,  MINM3D,  MAXMOD,  MODES 

2,  MAXK,  IFWA1,  LOCDT , LOCDTK,  ITHWAV,  NWAVES,  NWFTABI41) 

3,  HILO,  DYX , PYX,  PDYX,  PEVAL,  PRK,  FAZ,  SGNFZ2,  FAZ2 

4,  FAZ3,  XDEP,  FSRC,  VAR,  SIGNAL,  SIGCUT(BOO) 

EQUIVALENCE  ( T EMP 1 , S IGC JT  ) 

DI MENS ICN  TEMPI! 9, 1 ) 


••••SUMMARY  OF  APPROACH*** • 

TOTAL  SIGNAL  IS  S I GTOT  = SUMOV ERMOOESI SUMO VEKWAVEF AMI  LI E S ( V* SX ) ) 
WHERE  V DEPENDS  ONLY  ON  THE  VAR IABLt  (SIGNAL)  BEING  COMPUTED 
AND  SX  = RE ( S*X  D ) OR  SX=IM(S*XD).  HERE  S DEPENDS  ONLY  ON  THE 
SOURCE  MODEL  AND  XU  CONTAINS  THE  X DEPENDENCE. 

CALL  TIMER! 14) 

SKIP  IF  NOT  1ST  PASS  OF  CASE 
IF  (ITHOBS  .NE.  1)  GO  TO  10 

COMPUTE  BCDY  SOURCE  PARAMETERS  IF  BODY  MODEL  USED 
IF  ( I BODY  .NE.  0)  CALL  BO  DY  1 
SUPERSTRUCTURE  SOURCE  PARAMETERS 
IF  (ISUPR  .NE.  0)  CALL  SUPR1 
WAKE  SOURCE  PARAMETER 

START  OF  WAKE  COLL  APSE = INPUT  M UL T IP L I ER * NOMI NA L START  (SEE  DTWAKE ) 
IF  (IWAKE  .NE.  0)  XWAKE  = CWAKX*XWNOM 

c 

t RE  AO  IN  DISPERSION  TABLES,  SET  UP  WAVE  FAMILY  EDGE  TABLES 

1C  CALI  SPDTAB 

C PRINT/PLOT  DISPERSION  RELATION  ON  1ST  PAS> 

IF  (ITHOBS  .EQ.  1)  CALL  SPDTPP 

C 
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C SKIP  IF  NC  GRID  DfcFINED 

IF  INY  .LT.  1 .Ok.  NX  .LT.  I)  GO  TO  40 
C LOOP  HJR  EACH  X (DOWNSTREAM  STATION) 

DO  30  IT HX= It  NX 
X = XMIN  ♦ DX*FL0mT(  ITHX-1 ) 

C LC OP  FOR  t ACF  Y (TRANSVERSE  COORDINATE) 

DU  2:0  l T HY=  1 * NY 
C NOTE  Y IS  ALWAYS  NEGATIVC 

Y = - ( Y M I N + UY*  FLOAT ( I THY -1  ) ) 

YX  = -Y/X 

C COMPUTE  SIGNAL  AT  POINT  DEFINED  BY  X,  YX , OBSObP 

CALL  SP1PNT 

C ACCUMULATE  AND  OUTPUT  (TO  PP  PROCESSOR)  SIGNAL  DATA 

CALL  SPCJTS 
20  CONTINUE 
30  CONTINUl 
AO  CALL  T IMER(-IA) 

RETURN 
END 

SUBROUTINl  SPCUTS 

INITIALIZE  PP  FORMAT,  ACCUMULATE  AND  OUTPUT  DATA  FOR  EACH  CUT, 
AND  WRITE  FP  ID  8LUCK.  THREE  CASES  ARE  HANDLED--  X-Y  GRID, 

Z-Y  GRID,  Z-X  GRID 

COMMON  /GRID/  08S0EP,  NOBS,  COBS,  OBSMAX,  TABOBS(IOO),  ITHOBS 

1,  X,  CX,  XMIN,  NX,  ITHX,  Y,  DY , YMIN , NY,  ITHY,  MODE  1 , MQDEN 

2,  IVAR,  IPRDT , I PP  DT( 9 ) , XPMAX,  YPM A X , 1PPPSD,  I PREOG 

3,  ISPhAS 

COMMON  /NAME/  NAMES(2,I0),  0TNAMS(2,9) 

COMMON/ PPCOM/ 

1 LLNPP,  PNAMb,  PM  I N,  PMAX,  PLEN,  VNAME , VMIN,  VMAX 

2,  VLEN,  FNAME12),  F M I N , FMAX,  FLEN,  FTODP , T I TLE ( 2 ) 

3,  ICCUR,  IPLTYP,  I PLOT , IPRINT,  I ED  I T , NP,  IVLIST,  NOPP 

A,  IOPP,  NV,  IS YM 

E,  LNDPP,  I BLOK S I 1 ) 

COMPLEX  XCEP,  FSRC 

COMMON  //  RK,  EVAL,  DID<,  D2L , PSIO,  DPSIO,  DP  SI  B , WAKI,  SUPT 
It  YX,  D3L,  XI,  ETA,  INRANG,  MODE,  MINMOD,  MAXMOD,  MODES 

2,  MAXK,  I-WA1,  LOCDT,  LOCDTK,  ITHWAV,  NWAVES,  NWFTAB(AI) 

3,  HILO,  C/X,  PYX,  PDYX,  PEVAL,  PRK,  FAZ,  SGNFZ2,  FAZ2 

A,  FAZ3,  XDEP,  FSRC,  VAR,  SIGNAL,  SIGCUTI  800) 

EQUIVALENCE  (TEMPI, SIGCUT) 

DI  MENS  ION  TEMPK9,  1) 


SKI P FOR  Z-X  GRID 
IF  (NY  .EU.  I)  GO  TO  30 
C X-Y  OR  Z-Y  GRIC.  SAVE  SIGNAL  AT  CURRENT  Y VALUE 

SIGCUT ( ITHY ) = S IGNAL 
C RETURN  IF  Y CUT  NOT  COMPLETED 

IF  (ITHY  .LT.  NY)  RETURN 
C SKI  P FOR  Z-Y  GRIC 

IF  (NOBS  . GT  . 1 ) GO  TD  20 

C X-Y  GRID.  INITIALIZE  PP  FORMAT  BEF3RE  WRITING  1ST  CROSS  CUT 

IF  (ITHX  .EG.  1)  CALL  SET  I D I AHCUTS , 0,  IHX,  2H-Y,  NAME S ( 1 , 1 VAR ) ) 
C WRITE  CROSS  CUT 

CALL  WRTDATd,  NY,  SIGCUT,  1,  X) 

C RETURN  IF  NOT  LAST  PASS 

IF  (ITHX  .LT.  NX)  RETURN 
C WRITE  PP  ID  BLOCK 
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VHIN  = YMIN 
VMAX  = -Y 

CALL  HRT I D ( NY  » 0,0  ) 

RETURN 

C 

C Z-Y  GRIO.  INITIALIZE  PP  FORMAT  BEFORE  WRITING  1ST  CROSS  CUT 

20  IF  ( IT  HOBS  .EC.  1) 

1 CALL  S ET  ID(  4HCUTS,  0,  5HDEPTH,  2H-Y,  NAME S ( 1 , l VAR ) ) 

C WRITE  CROSS  CUT 

CALL  WRT DAT ( 1,  NY,  SIGCJT,  1,  OBSOEP  ) 

C RETURN  IF  NOT  LAST  PASS 

IF  (ITHOBS  .LT.  NOBS)  RETURN 
VMIN  = YMIN 
VMAX  = -Y 

C MAKE  FUNCTION  POSITIVE  TO  THE  LEFT 

FT  OOP  = -FTCCP 
CALL  WRT I 0 ( NY , 0,0) 

RETURN 

C 

c Z-X  GRIC.  SAVE  SIGNAL  AT  CURRENT  X STATION 

30  SIGCUT ( ITHX ) = S IGNAL 
C RETURN  IF  X CUT  NOT  COMPLETED 

IF  (ITHX  .LT.  NX)  RETJRN 
C INITIALIZE  PP  FORMAT  BEFORE  WRITING  1ST  CUT 

IF  (ITHOBS  .EQ.  1) 

1 CALL  SET  ID( 4HCUTS,  0,  5HDEPTH , 1HX,  NAME S ( 1 , 1 VAR ) J 

C WRITE  AXIAL  CUT 

CALL  WRT  DAT  ( 1 , NX,  SIGCJT,  1,  OBSDEP  ) 

C RETURN  IF  NOT  LAST  PASS 

IF  (ITHOBS  .LT . NOBS)  RETURN 
C MAKE  FUNCTION  POSITIVE  TO  THE  LEFT 

FT  OOP  = -FTCCP 
C WRITE  PP  10  BLOCK 

VMIN  = XMIN 
VMAX  = X 

CALL  W RT  I C ( NX  , 0,0) 

RETURN 

END 

SUBROUTINE  S PC  IS P( JEDGE  ) 

C LINEAR  INTEWP  FOR  CISPERSION  VARIABLES  AS  FUNCTION  OF  EVAL 

C 

COMMON  /BODY/  IFOOY,  IPBODY,  BODDEP , 80DDIA,  300LEN,  OODSPD 
1,  RBSEP2,  RBSTR,  RBLIM 

COMMON  /SUPER/  ISUPR,  SUPTOP,  SUPBOT,  IPSUPR,  SUSTR,  SUSEP2 
1,  SUPMID,  SULIM,  SJPDIA,  SUPLEN 

C 

COMMON  /WAKE/  IWAKE,  CWAKR,  CWAKX,  XWA<E,  WAKRAD,  XWNOM 
1,  RESLVS,  CWAKM 

C 

COMPLEX  XDEP,  FSRC 

COMMON  //  RK,  EVAL,  DLDK,  C2L , PSIO,  DPSIO,  DPSIB,  WAKI  , SUPT 

1,  YX,  D3L,  XI,  ETA,  INRANG,  MODE,  MINMOD,  MAX.MOD , MODES 

2,  MAXK,  IFWA1,  LOCDT,  L3CDTK , ITHWAV,  NWAVES,  NWF  TAB ( 41 ) 

3,  HILO,  DYX , PYX,  PDYX,  PEVAL,  PRK,  FAZ,  SGNFZ2,  FAZ2 

4,  FAZ3,  XDEP,  FSRC,  VAR,  SIGNAL,  SIGCUTI600) 

EQUIVALENCE  (T EMP 1, S IGCUT ) 

DIMENS  ION  TEMPK9,  1) 

COMMON  //  TK(iOO),  T EV AL  ( 100 , 4 1 ) , TDLDK(  ICO, 41 ) , TD2L(100,4l) 

1,  T PS  1 0(  100 ,41),  TGPSIO(  100,41),  TOP  SIB  ( 100,41 ) , TWAKI  (1 00 ,41 ) 

2,  T SUPT  ( 100,  41),  TYX(100,41),  YXEDGf  20,  <tl ) , EVLEDG  (20 ,41 ) 

3,  L IMEOG(  20,  41 ) , I VDEDG(  20,  41 ) 
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c 

C SKIP  IF  RGUTINi:  IS  BEING  USED  TO  FIND  WAVE  FAMILY  EDGES 

IF  (JEDGE  .NE.  0)  GO  TO  10 
C CONVERT  YX  TO  cVAL 

CALL  SPEVAL 

C RP TURN  IF  YX  IS  OUTSIDE  RANGE  OF  SPtCIFIED  WAVE  FAMILY 

IF  { INRANG  . fcU  . 0)  RETURN 

C LUCDT  IS  SUCH  THAT  T E V AL ( L OC C T - 1 ) .LT.  E VAL  .LE.  TEVAL(LCCDT) 

C L DC DTK  IS  THt  CORRESPONDING  INDEX  FOR  THE  K (WAVENUMBER)  LIST 

C GET  LINEAR  INTERP  COEFFICIENTS 

10  C2  = ( EVAL-1  tV  AL(L0CDT-1  ) ) / ( TEVAL  (LOCOT)-TEVAL  (LOZUT-l ) ) 

Cl  = 1.  - C2 

C INTERPOLATE  FOR  K,  C(6VAL)/DK,  D2(EVAL)/DK2  WHERE  EVAL=1/C**2 

RK  = Cl «TK( LCCDTK-1 ) ♦ C2*TK ( LOCDTK ) 

OLDK  = C1«TDLUK( LUCOT-1  ) ♦ C 2*  TDL  DK  ( L DC  0 T 1 
02  L = C1*TD2L( LOCDT-1 ) ♦ C 2*  TO  2L ( LOCD  T ) 

C THE  ABOVE  VARIABLES  ARE  SUFFICIENT  FOR  FINDING  WAVE  FAMILY 

C EDGES.  KtTURN  IF  THAT  IS  WHAT  THE  ROUTINE  IS  BEING  USED  FOR. 

IF  (JEDGE  .NE.  0)  RETJRN 
C COMPLETE  THE  DISPERSION  RELATION 

C NORMALIZED  E IGENFJNCT  I ON  PSI  AMD  D(PSI)/DZ  AT  OBSERVATION  DEPTH 

PSIC  = Cl  «TPS  I0(  LOCCT-1  ) + C 2*TPS  10  ( LOCC  T ) 

DPS'O  = Ci*TDPSIO(LOCDT-l)  + C2*TDPSI0( LOCDT) 

C D ( PS  I ) / DZ  AT  BODY  DEPTH 

IF  ( I BODY  .NE.  0)  CPS  I B = C 1*  TDP  S I B ( L DC  D T- 1 ) + C?.»  TDP  SI  B ( LOCDT) 
C WAKE  SOURCE  TtRM 

IF  (IWAKt  .NE.  0)  W A< I = C i*TWAK I ( L OCO T- 1 ) * C Z* TWA KI  ( LOCDT) 

C SUPERSTRUCTURE  TERM  = PSIIBUTTOM  OF  SUPER)  - PSI  (TOP  OF  SUPER) 

IF  ( IS  U PR  .NE.  0)  SUPT  * C 1*  T SUPT (LOCDT-1 ) + C2* TSUP T (LOCDT) 

C COMPUTE  D3  ( EVAD/UK3  = D(  D2L  )/DK 

D3L  = (TD2L( LOCDT )-TD2L ( LOCDT- 1) ) / ( TK ( LDCD TK ) - TK ( LOC OTK  -1 ) ) 

RETURN 

END 

SUBROUTINE  SPCTAB 

C READ  DISPERSION  TABLE  AMD  PERFORM  FINAL  ADJUSTME  ITS  ON  IT 

C 

COMMON  /BODY/  I BODY » IPBODY,  BODDEP,  BODDIA,  dUOLEN,  BOOSPD 

1.  RBSEP2,  RBSTR,  RBLIM 

C 

COMMON  /CONST/  JDK,  JDMODE,  JDTCL , PI,  NULL,  JDCKL,  JDMFT 
1»  JCCKSV,  JDMSP,  JDEDGE 
C 

COMMON  /FILES/  NTILIB,  NT0LI5,  NTPDEF , MTPID,  NTPDAT,  NTPLOT 

1,  NTDTAB,  NTEVEC,  NTT  E MP 

C 

COMMON  /GRID/  OBSDEP,  NOBS,  DOBS,  OBSMAX,  TABOBS(IOO),  ITHOBS 

OX,  XMIN,  NX,  ITHX,  Y,  DY,  YMIN*  NY,  ITHY,  MOOE1,  MODEN 

2,  IVAR,  IPRDT,  IPPDT19),  XPMAX,  YPMAX , IPPPSD,  I PREDG 

3,  ISPHAS 
C 

COMMON  /SUPER/  ISUPR,  SUPTOP,  SUPBOT,  IPSUPR,  SUSTR,  SUSEP2 
1,  SUPMID,  SULIM,  SJPDIA,  SUPLEN 

C 

COMMON  /wake/  iwake,  cwakr,  cwakx,  XWAKE,  WAKRAD,  XWNOM 

1|  RESLVSt  CWAKM 

c 

COMPLEX  X C EP , FSRC 

COMMON  //  RK,  EVAL,  DLOK,  D2L,  PSIO,  DPSIO,  DPSIB,  WAKI,  SUPT 
1»  YX,  03 L , XI,  ETA,  INRANG,  MODE,  MINMOD,  MA XMOD , MODES 

2 » MAXK,  IFWAi,  LOCOT,  LOCDTK,  ITHWAV,  NWAVES,  NWFTAB(Al) 

3*  HILO,  CYX,  PYX,  PDYX,  PEVAL,  PRK , FAZ,  SGNF  Z2 , FAZ2 
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4,  FAZ3,  XDEP,  FSRC,  VAR,  SIGNAL,  SIGCUTI600) 

EQUIVALENCE  IT EMPi,S  IGC JT ) 

DIMENSION  TEMP1I9, 1) 

COMMON//  TKIIOO),  T EV AL I 1 00 , A 1 ) , TDLDKI  100,41 ) , TD2L(100,41) 

1,  T PS  1 0 1 100, A 1 ) , TDPSIOI  100,41),  TD3  S IB  I 100, A1 ) , TWA KI  1 1 00  , A i ) 

2,  TSUPT  I 100 , A i ) , T V X I 1 00 , A 1 ) , YXEDG! 20, 4 1 ) , F VL EDS  I 2 0 , A 1 ) 

3,  L I ME  CG 1 20 , A1 ) , I N DEDGI  20 , A 1 ) 

C 

C 

CALL  TIMERI15) 

C MDDE1  AND  MCCEN  ARE  INPUT  LIMITS  OF  DESIRED  MODES.  SET  UP 

C INTERNAL  STORAGE  AND  OO-LOOP  LIMITS  TO  SQUEEZE  OUT  UNUSED  MODES 

MINMOD  = 1 

MAXMOD  = MUDEN  -MUDE1 

C CHECK  MODE  RANGE  AGAINST  AVAILABLE  STORAGE 

IF  (MAXMOD  .LE.  JUMSP)  GO  TD  20 
WRI TE ( 6 ,10 ) M0CE1, MODEM, JDMSP 
10  FORMAT ( 29H  MOUE  RANGE  EXCEEDS  DIMENS  ION, 31 10) 

CALL  ERRXIT 

C DISPERSION  TABLE  IS  ON  TAPE  NTDTAB 

20  REWIND  NTDTAB 

READINTDTAB)  MODES 

C SKIP  IF  DISP  TABLE  FAS  AT  LEAST  AS  MANY  MODES  AS  DESIRED 

IF  IMOGEN  .LE.  MOOES)  GO  TO  AO 
WRI TE 1 6 , 30 ) MODEN, MCOES 
30  FORMAT (20H  MODEN  EXCEEDS  MODES, 21 10) 

CALL  ERRXIT 

C LOOP  POR  EACH  ENTRY  IVALOE  OF  K)  IN  DISP  TABLE,  BUT  DONT 

C EXCEED  STORAGE  CIMCNSION 

40  DO  70  I K= 1 » JDK 

C READ  K, ILAMBDAIM), DLDK(M),PSIO(M),OPSIO(M) ,DPSIBIM), 

C WAKI  IM),SUPT  IM),  S JPB I M ),DLDK2IM),M=1, MOOES) 

READINTDTAB)  RK,  I I T EMP  1 1 I,  M ) , I * 1,  9 ) , M *1,  MODE  S ) 

C SKIP  OUT  OF  LOOP  WHEN  ENTIRE  TABLE  HAS  BEEN  READ 

IF  IEDF, NTDTAB)  b0,50 
C DATA  WERE  READ.  SAVE  VALUE  OF  K 

50  TKIIK)  = RK 

00  60  MUDE=MI NMOD, MAXMOD 

C NOTE  THAT  HERE  I AND  EVERYWHERE  ELSE  IN  THE  SP  ROUTINES),  THE 

C VARIABLE  -MODE-  IS  THE  STORAGE  INDEX  OF  THE  MODE  BEING 

C CONSIDERED.  NOW  SET  ACTUAL  MODE  NUMBER. 

MN  = MODE  +M0UE1  -1 

C TRANSFER  VARIABLES  FROM  TEMP  STORAGE  TD  DISPERSION  TABLES 

TEVALI  IK, MODE)  = TEMPI!  1,MN) 

TDLDKI  IK, MODE)  = TEMPI!  2, KN) 

TPS  1 01  IK, MODE)  = TEMPI! 3, MN) 

TDPSIDI IK,MDCE)  = TEMP1I4,MN) 

TDPSIBI  IK, MODE  ) = 0 . 

IF  1 1 BODY  .NE.  0)  T DP  S IB!  IX  , MO  D E ) = TEMP  II  5,  MN) 

TWAKI I IK, MODE)  = 0. 

IF  IIWAKE  .NE.  0)  TWAiXII  IK,  MODE)  = TEMP1(6,MN) 

C SUPERSTRUCTURE  TERM  IS  PS  II  BOTTOM  ) -P S 1 1 TOP ) 

TSUPTI IK, MOOE ) = 0. 

IF  ( ISUPR  .NE.  0)  TSUPTI IK, MODE)  = TEMP1!8,MN)  -TEMP1!7,MN) 

TD2  LI  I K , MCDE)  = TEMP1(9,MN) 

60  CONTINUE 
70  CDNTINUl 
C 

IK  = JDK+1 

C SET  NUMBER  OF  ENTRIES  IN  TABLE 

80  MAXK  = IK-I 

C 
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C CONSTRUCT  WAVE  FAMILY  EDGE  TABLES  AND  TABLE  OF  STATIONARY 

C PHASE  POINTS 

CALL  SPWFAM 
C 

C SKIP  IF  WARE  IS  OFF 

IF  ( I WAKE  .EQ.  0)  GO  TO  1 30 
C FINISH  COMPUTATION  OF  T Hr  WAKE  SOURCE  TERM 

C LCOP  FOR  EACH  MODE 

GO  110  MCCE=M I NMOC,  M A < MOD 
C GET  FWA-1  OF  THIS  MODE  IN  DISP  TABLES 

IFWA1  = ( MODE- 1 ) *J  DK 

C ADDRESSES  OF  1ST  AND  LAST  ENTRIES  FOR  THIS  MODE 

L I Ml  = IFwAl  ♦LIMEDGI It  MODE ) 

L I M2  = IFwAl  + M AX K 

C LOOP  FOR  tACH  lNTRY  IN  THE  TABLE 

DO  90  L0CDT=LIM1,LIM2 

C FINISH  COMPUTATION  OF  WAKE  SOURCE  TERM 

90  TWAKI(LOCDT)  ^ 2 . *CW A< M*BODS PD* TE V AL ( L3C DT ) * T WAK I < L OC D T ) 

C SKIP  IF  1ST  CCGC  IS  AT  <=0 

IF  ( EV  LEUG ( 1 1 MODE ) . EQ . T EVAL  ( I FW A 1+ 1 >>  GO  TO  ICC 
C FILL  IN  SLOT  PRECECING  THE  1ST  TABLE  ENTRY  BY  EXTRAPOLATION 

TWAKI  ( LIM1-1  > = TWAKI(LIMl)  + ( TE  VAL  ( L I M 1- 1 ) - T t VA  L ( L I Ml ) ) 

1 * (TWAK I(  L IM1  + 1 ) -TWA< I( L IM1) )/(TE VAL (LI Ml  + 1) -TE  VAL  ( LI  Ml)  ) 

GO  TO  110 

C FINISH  COMPUTATION  AT  K=0  ENTRY 

100  TwAKI ( I FW  A 1 ♦ 1 ) = 2 .*CWAKM*BOOSPD*TEVAL( IFWAl+l )*TWAKI  ( IF WA1+ 1 ) 

110  CONTINUE 

130  CALL  T I MEM  -lb  ) 

RETURN 

END 

SUBROur INL  SPCTPP 

C PRINT/PLOT  DISPERSION  RELATION 

C 

COMMON  / BCDY/  IEODY,  IPBUDY,  BODDEP,  BODDIA,  UUDLcN,  bOOSPD 
1,  RBS  lP2  t RBSTR,  RBLIM 

C 

COMMON  /GRIG/  OBSUEP,  NOBS,  COBS,  OBSMAX,  TABOBS(IOO),  ITHOBS 

1,  X,  OX,  XM  IN , NX,  I THX , Y,  DY,  YMIN,  NY,  ITHY,  MODE  1 , MODEN 

2,  IVAR,  IPRDT,  IPPDTI9),  XPMAX,  YPMAX,  IPPPSD,  IPREOG 

3,  ISPHAS 
C 

COMMON  /NAME/  NAMcS(2,10),  DTNAMS<2,9) 

C 

COMMON/ PPCOM/ 

1 LENPP,  PNAME,  PMIN,  PM  AX , PLEN,  VNAME,  VMIN,  VMA X 

2,  VLEN,  FNAMEI2),  FM IN , FMAX,  FLEN,  FTODP,  TITLE ( 2 ) 

3,  IUCUR,  IPLTYP,  I P LOT , IPRIwf,  I ED  I T , NP  , IVLIST,  NOPP 

IUPP,  NV,  ISYM 

E,  ENDFP,  I BLOKS ( 1 ) 

C 

COMMON  /SUPLR/  ISUPR,  SJPTUP,  SUPBOT,  IPSUPR,  SUSTR , SUSEP2 
It  SUPMID,  SULIM,  SUPDIA,  SUPLEN 

C 

COMMON  /WAKE/  IWAKE,  CWAKR,  CWAKX,  XWAKE  > WAKRAD,  XWNOM 
1,  RESLVS,  CWAKM 

C 

COMPLEX  XGEP,  FSRC 

COMMON  //  RK,  EVAL,  DLO<,  D2L,  PSIO,  DPSIO,  CPSIB,  WAKI  , SUPT 

1,  YX,  D3L , XI,  ETA,  INRANG,  MODE,  MINMOD,  MAXMOO,  MODES 

2,  MAXK,  IFWA1,  LOCDT , LOCDTK,  ITHWAV,  NWAVES,  N WF  T A 8 (41) 

3,  HILC,  CYX , PYX,  POYX , PEVAL,  PRK , FAZ,  SGNFZ2 , FAZ2 

A,  FAZ3,  XDEP , FSRC,  VAR,  SIGNAL,  SIGCUTUOO) 
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EQUIVALENCE  { T EMP 1, S IGC JT  ) 

DIMENSION  T EMP 1 ( 9 » I) 

COMMON  //  TKI100),  T EV  A _ ( 100,41),  TDL  DK  ( 1 00 , 41  ) , T02L(100,41) 

1,  TPS  10(100,41  ) , TDPSIOI  100,41),  TOP  SItJI  100,  41 ) , TWAKI  (100.41) 

2,  TSUPTI  100,41 ),  T Y X ( 100, 41),  YXEDSI  20, 41 ) , E VL5  OS  ( 2 0 ,41  ) 

3,  LIMEDGI 20, 41 ),  I N DEDGI 20 , 4 1 ) 


SKIP  IF  SPECIAL  PRINT  IS  OFF 
IF  (IPkDT  .EC.  0)  GO  TO  100 
LOOP  FOR  EACH  MODE  IN  TABLE 
0 0 90  M0CE=MI  NMOD.MAXMOD 
ACTUAL  MODE  NUMBER 
MN  = MODE  + MODE  1 -1 
WRITEIS.30)  MN 

30  F (JRMAT  ( 2 2 H 1 ClSPcRSION  RELAT  IDN/7H  MODE  , I 3/  1H  0 , 6X  , IrtK  , 9X  , 

1 4H-Y/X,7X,bHLAMBDA,5Xi  5HDL  /DK  , 6X,  7HD  2L/0K2 ,4X  ,6HW(0iiS)  ,5X, 

2 1OHCW/0Z (OBS  ), IX,  10HCW /DZ ( BOD ) , IX , 5H TWAKE , 6 X , 5H T SUPR ) 
PRESET  K INCEX  OF  NEXT  ENTRY  TO  PRINT 
NEXT  = 1 

NUMBER  OF  WAVE  FAMILIES  IN  THIS  MODE 
NWAVES  = NWFT  AB( MODE  ) 

LI  M = NWAVES  ♦ 1 
DO  80  ITHW  AV= 1 , L I M 

PICK  UP  K INDEX  OF  LAST  ENTRY  IN  THIS  WAVE  FAMILY 
LAST  = LIMECG(  ITHWAV, MODE  ) 

IF  (ITHWAV  .NE.  LIM)  LAST  = LAST  - 1 

SKIP  IF  LNTIRl  WAVE  FAMILY  LIES  BETWEEN  ADJACENT  TABLE  POINTS 
IF  (LAST  .LT . NEXT ) GD  TO  6C 

WRITE (8,50)  ( I ,TK(  I ) ,TYX(  I , MODE ) , TE VA L I I .MODE)  , TDLD K ( I .MODE) 

1,  TD2L(  I, MODE),  TPS  I 01  I , MODE  ) , TDP  SI  0 I I , M JOE  ) , TO  P SI  B ( I , MODE  ) 

2,  TWAKI ( I, MODE) , TSUPTI  I , MODE  ) , I =NEXT , LA S T ) 

50  FORMAT  ( IX,  13,  10EU.3) 

NEXT  = LAST  + 1 
60  IF  (ITHWAV  .NE.  LIM) 

1 WRITE(b,70)  YXEDG( ITHWAV, MODE), E VLEDG ( I THWAV, MODE) 

70  FORMAT ( 11X.4HEDGE,  2E11 . 3) 

80  CONTINUE 
90  CONTINUE 

SKIP  IF  NOT  PRINTING  WAVE  FAMILY  EDGE  TABLE 
100  IF  (IPREOG  .EQ.  0)  GO  TO  200 
MR  IT  E ( 6 , 1 10  ) 

110  F ORMAT ( 25H1  WAVE  FAMILY  EDGE  TABLE) 

LOOP  FOR  EACH  MODE 
DO  140  MGDE=M I NMOD.MAXMOD 
ACTUAL  MOCE  NUMBER 
MN  = MODE  + MUDEl  -1 
WRITE(6,120)  MN 

120  FORMAT ( 10H0 MODE,  I3/6X.4H-Y/X, 1 OX , 6HL AMBDA ) 

NUMBER  OF  WAVE  FAMIL  IES 
NWAVES  = NWFT  AB( MODE  ) 

WRITE  (6, 130)  ( I , YX  EDG(  I , MODE  ) , EVL  EDG(  I,  MODE)  ,1  *1  .NWAVES) 

130  FORMAT ( IX, I2.2E14.6) 

140  CONTINUE 

LOOP  FOR  EACH  D.T  . VARIABLE  WHICH  CAN  BE  SENT  TO  PP  PROCESSOR 
200  DO  310  I THV AR= 1, 9 
C SKIP  IF  PP  OPT  iON  IS  OFF  FOR  THIS  VARIABLE 

IF  ( I PPDT ( ITHVAR)  .EQ.  0)  GO  TO  310 
C SKIP  IF  DESIRED  VARIABLE  HAS  NOT  REEN  COMPUTED 

IF  (ITHVAR  .EQ.  4 .AND.  IBODY  .EQ.  0)  GO  TO  310 
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C 

c 

c 

c 

c 


IF  (ITHVAR  .EQ.  5 .AND.  IW  AK  E .EQ.  0)  GO  TO  31C 

IF  (ITHVAR  .EQ.  6 .AND.  ISUPR  .EQ.  0)  GO  TO  31C 

PRESET  THE  PP  SPECS 

CALL  SET  I C ( CT N AMS ( 1* ITHVAR ),  1,  4FMUDE,  1HK , DTNAMS (1*1 TH VAR ) ) 

INDICATE  VARIABLE  LIST  IS  FIXED 

IVLIST  = 2 

LOOP  FOR  EACH  MODE 

DO  300  MCDE=MINMOD,  MAXMOD 

FLOAT  ACTUAL  MODE  NUMBER 

RMODE  = MUDt  ♦ MtJCEl  -1 

JUMP  ON  VARIABLE  TO  BE  DISPLAYED 

GO  TO  (210,220,230,240, 250,260, 270, 28C, 290 , ITHVAR 


210 

CALL  W RT  DAT ( 1 , 
GC  TO  300 

MAXK, 

TDLD<(  1 , MODE  ), 

1,  RMODE) 

220 

CALL  WRTDAT ( 1 , 
GO  TO  300 

MAXK, 

TPSIOI l.MODE ) , 

1,  RMODE) 

230 

CALL  W RT  CAT ( 1 , 
GO  TO  300 

! UK, 

r DPS  IOC  1 , MODE  ) 

, 1,  RMODE) 

240 

CALL  WRTDAT (1, 
GO  TO  300 

MAXK, 

T DPS  I B ( 1 , MODE ) 

, i,  RMODE) 

250 

CALL  WRTDAT  ( L I MEDG(  1 
GO  TO  300 

, M D DE ) « MAXK,  TWAK I ( 1 , MODE ) 

260 

CALL  WRT  DAT ( 1 , 
GO  TO  300 

MAXK, 

T S JPT  ( i , M ODE  ) , 

1,  RMODE) 

270 

CALL  WRTDAT  ( 1, 
GC  TO  300 

MAXK, 

TEVAL(  1 , MODE  ), 

1,  RMODE) 

280 

CALL  WRTDAT (1, 
GO  T U 300 

MAXK, 

T D2L(  1 , MODE ) , 

1,  RMODE) 

290 

300 

CALL  W RTDAT ( L I MFDG(  1 
CONTINUE 

, M DDE  ) , MAXK,  TYX ( 1 , MODE ) , 

WRITE  THE  PP  ID  RECORD 
CALL  W RT  I D ( MAX  K , TK,  1) 

310  CONTINJE 
RETURN 
END 

SUBROUTINE  SPEDGE 

TEST  FOR  AND  FIND  WAVE  FAMILY  EDGES  (EXTREMA  OF  YX) 

COMMON  /CONST/  JDK,  JCMODE,  JDTCL,  Pi,  NULL,  JDCKL,  JDMFT 
1,  JDCKSV,  JDMSP,  JDEDGE 


COMPLEX  XDEP,  FSRC 

COMMON  //  RK,  EVAL,  DLDK,  D2L , PSIO,  DPSIO,  DPSI6,  WAKI  , SUPT 

1,  YX,  D3L,  XI,  ETA,  INRANG,  MODE,  MINMOD,  MAXMDD,  MODES 

2,  MAXK,  IFWA1,  LOCDT,  LDCDTK , ITHWAV,  NWAVES,  NWF  TAB (41 ) 

3,  HILO,  DYX , PYX,  PDYX,  PEVAL,  PRK,  FAZ,  SGNFZ2,  FAZ2 

4,  FAZ3,  XDEP,  FSRC,  VAR,  SIGNAL,  SIGCUT(SOO) 

EQUIVALENCE  ( T EMP 1 , S IGC  JT  } 

DIMENSION  TEMP 1( 9, 1) 

CQMOON  //  TK(lOO),  T EV  AH  1 00 , 4 1 ) , TDLDX  ( 1 00, 41 ) , TD2LU00,4l) 

1,  TPS  I0( 100,41 ),  TDPSIOl  100, 41  ),  TDP SIB ( 1 00 , 41 ) , T WA KI  ( 1 00  ,41 > 

2,  TSUPT(  100,41  ),  TYX(100,41),  YXEDG(  2C , 4 1 ) , E VLED3  (20 ,41  ) 

3,  L I MEDG ( 20 , 4 1 ) , INDEDG(  20, 41  ) 


NOTE  EDGES  ARE  THE  EXTREMA  3F  YX  AS  A FUNCTION  OF  EVAL 
HIL0=1  IF  LOOKING  FOR  A MINIMUM  IN  YX,  H I LO  =- 1 FOR  A MAXIMUM 
FIND  EDGE  IF  DERIVATIVE  HAS  CHANGED  j»3N 
IF  ( DYX *H I LO  .LT.  0.)  RETURN 
C FIND  EXTREMUM  BETWEEN  PEVAL  AND  EVAL. 

C SAVE  VALUES  ON  RIGHT  SIDE  OF  EXTREMUM 

SYX  = YX 
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RRK  = PK 

C 10  HALVING  LCOPS  INCREASE  RESOLUTION  BY  FACTOR  OF  1CZ* 

00  20  IT  ER= 1 , 10 

C HALVE  THE  INTERVAL 

EVAL  = .5*(  PEV  AL  +REVAL  ) 

C INTERPOLATE  FOR  RK,  DLDK,  02L  AS  FUNCTIONS  OF  EVAL 

CALL  SPCISPI  1) 

C COMPUTE  YX  A\L  DYX  FROM  EVAL,  RK , DLDK , D2L 

CALL  SPFUNCI 1) 

C SKIP  IF  EVAL  IS  RIGHT  OF  EXTREMUM 

IF  ( DYX  *H  ILO  .GT.  0.)  GO  TO  10 

C EVAL  IS  LEFT  OF  lXTRlMUM.  REPLACE  LEFT  POINT 

PYX  = YX 
PO YX  = DYX 
PEVAL  = EVAL 
PRK  = KK 
GO  TO  :o 

C EVAL  IS  RIGHT  OF  EXTREMUM.  REPLACE  RIGHT  POINT 

10  RYX  = YX 
RD YX  = DYX 
REVAL  = EVAL 
RRK  = RK 
20  CONTINUE 

C 

NWAVES  = NWAVES  + i 

C SKIP  IF  STORAGE  NOT  EXCEEDED 

IF  (NWAVES  .LT.  JDECGE)  GO  TO  12C 
MR  I TE ( 6 , 1 10 ) JCEDGE, MODE 

110  FORMAT  ( 32H  WAVE  FAMILY  EDGE  TABLE  EXCEEDED  , 21  i 0) 

CALL  ERRXIT 

C EXTREMUM  BETWEEN  P AND  R.  SELECT  THE  BETTER  AND  INSERT  INTO 

C EOGE  TABLES 

120  IF  (HI LO* ( RYX-PYX ) .LT.  0.)  GO  TO  i30 
YXEOG(NWAVES»MODE)  = PYX 


EVLEOG(NWAVCS,MODE)  = PEVAL 
GO  TO  1 AO 

130  YXEOG( NWAVES,  MODE  > = RYX 

EVLEDG( NWAVES , MODE ) = REVAL 
1A0  LIMEDG(NWAVES,MOUE»  = L3CDT< 
INDEOG(NWAVES,  MODE)  = LOCDTK 
C COMPLEMENT  THE  MIN/MAX  SEARCH  FLAG 

HILO  = -HILO 

C SET  PREVIOUS  POINT  = RIGHT  HAND  POINT... 

PYX  = RYX 
PDYX  * RDYX 
PEVAL  = REVAL 
PRK  = RRK 

C ...ANO  RESTORE  ORIGINAL  RIGHT  HAND  POINT 

YX  = S YX 
DYX  * SDYX 
EVAL  = SEVAL 
RK  = S RK 
RETURN 
END 

SUBROUTINE  SPEVAL 
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FINC  EIGENVALUE  EV  AL  AND  TABLE  POSITION  LOCDT  FOR  A GIVEN 
STATIONARY  PHASE  POINT  YX  AND  WAVE  FAMILY  ITHWAV 

COMMON  / BCDY/  I BODY , I P BODY  , BDDOEP  » BDDDIA,  BLiOLEN,  BOOSPD 
It  RBS  t P2 , RBSTR,  RBLIM 

COMMON  / CLNST / JDK,  JDMOCE,  JDTCL , PI,  NULL,  JDCKL  * JDMFT 
1,  JUCKSV,  JDMSP,  JDEDGE 

COMPLEX  XOEP,  FSRC 

COMMON  //  RK,  EVAL,  CLDK,  C2L , PSIO,  DPSIO,  DPSIB,  WAKI,  SUPT 

1,  YX,  D3L , XI,  ETA,  INRANG,  MODE,  MINMOD,  MA  XMOD  , MDDE S 

2,  M A X K , IFWAI,  LOCDT , LDCDTK,  ITHWAV,  NWAVfcS,  NWFTA3(41) 

3,  HILL,  DYX,  PYX,  PDYX,  PEVAL,  PRK,  FAZ,  SGNFZ2,  FAZ2 

4,  FAZ3,  XCEP,  FSRC,  VAR,  SIGNAL,  SIGCUT(cOG) 

EQUIVALENCE  { T EMP 1 , S IGCUT ) 

Cl  MENS  ION  T LMPK  9,  1) 

COMMON  //  TK(IOO),  T EV AL { 1 00 , 4 1 ) , TDL DK ( ICO , 41 ) , TD2L(100,4I) 

1,  T PS  I 0 { 100 , 4 1 ) , T DPS I0(  100,41),  TOP  SIB ( 100,41 ) , TWAKI  ( 1 00 ,41 ) 

2,  TSUPTI  100,41),  T Y X ( 100,41  I , YXEUG ( 20 , 41 ) , F VLEDG (20 ,41 ) 

3,  LIMLDG{  20,41  ),  I V DEDG1  20,  4 1 ) 


Gfc  T SINGLl  INDEX  bUUIVALENT  OF  ( I THWA  V , MDDE  ) FOR  ADDRESSING 
EDGE  TABLES 

J = ( MODE- 1 ) * J DEDGE  + ITHWAV 

SKIP  IF  YX=  -Y/X  IS  WITHIN  THE  RANGE  OF  THIS  WAVE  FAMILY 
IF  { (YXEDL(J)-YX  ) * ( YX  E DG(  J *1  )-YX)  .LE.  0.)  GU  TO  10 
SET  FLAG  SHOWING  THIS  WAVE  FAMILY  DDES  NDT  CONTRIBUTE  AT  YX 
INRANG  = 0 
RETURN 

SHOW  THIS  WAVE  FAMILY  DDES  CONTRIBUTE  AT  YX 
10  INRANG  = 1 

SET  FWA-1  OF  C ISPERS  ION  TABLES  FOR  THIS  MODE 
IFWAI  = ( MODE- 1 ) *J  DK 

SET  LIM1/LIM2  = INDEX  OF  L OW  ES  T /H I GHE  ST  VALUE  OF  YX  WITHIN 
RANGE.  SET  INC  = INCREMENT  IN  INDEX  TD  INCREASE  TYX(I). 

SET  SIGN  CF  2ND  DERIVATIVE  OF  PHASE  FUNCTION 
SKIP  IF  T ABLE  DECREASES 
IF  ( YX  EDO  ( J ) .GT.  YXCDGCJ  + l)  i GD  TD  20 
L l Ml  = LIMEDG(J)  + IFWAI 
LI  M2  = LIMECGU  + l)  -1  + IFWAI 
INC  = 1 
SGNFZ2  = 1. 

GO  TO  30 

20  LI  Ml  = LIMECGU  + l)  -1  ♦ IFWAI 
LI  M2  = L IMEDGl  J I + IFWAI 
INC  = -1 
SGNFZ2  = -1. 

C SKIP  IF  THERE  ARE  O.T.  POINTS  WITHIN  RANGE 

30  IF  (LIMEDGU  + l)  .GT  . LIMEDG(J))  GO  TO  40 
C ENTIRE  WAVE  FAMILY  LIES  BETWEEN  ADJACENT  TABLE  POINTS.  INTERP 

C BETWEEN  EDGES 

EVAL  = EVLECG(J)  + ( EV L EDG ( J ♦ 1 ) -E VLE DG( J ) ) / ( YXEDG { J + 1 ) -YXEDG ( J ) ) 
1 *( YX-YXEDGI J )) 

IOT  = LIME 
GO  TO  110 
C 

C FIND  PROPER  POSITION  IN  TY  X TABLE.  PICK  UP  PREVIOUS  POSITION 

40  IDT  = INDEDG(J)  + IFWAI 

IF  (YX  .GE.  TYXUDT))  GO  TO  70 
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C SKIP  If-  YX  LItS  8ETWEEN  EDGE  AND  TABLE  POINT 

IF  (YX  .LE.  TYX(LIMl))  GO  TO  60 

C TYX(LIMI)  .LT.  YX  .LT.  TYX(IDT)  FIND  PROPER  POSITION  IN  TABLE 

50  IDT  = IOT  -INC 

IF  (YX  .LT  . TYX ( IDT ) ) GO  TO  50 
GO  TO  90 

C INTERPOLATE  BETWEEN  WX(LIMl)  AND  YXED3(J+(  1-INE  ) / 2 ) 

60  I = J ♦ ( i-INC  )/  2 

DIV  = YX  ECG ( I)  - T YX ( L I M 1 ) 

IF  (DIV  .EQ.  0. ) DIV  = I. 

EVAL  = CVLcDG(I)  + ( EV L EDG ( I )- T EVAL ( L IB  1 ) ) /D I V * ( YX- Y XEOG ( I ) ) 
IDT  = LIMI  -INC 
C SAVE  POSIT  ICN  IN  T ABLE 

INDEOG(J)  = LIMI  -IFWA1 
GO  TO  110 
C 

C SKIP  IF  YX  LItS  BETWEEN  EDGE  AND  TABLE  POINT 

70  IF  (YX  .GE.  T YX ( L i M2 ) ) GO  TO  ICO 
C TYX(IDT)  .Lc.  YX  .LT . TYX<LIM2)  FIND  PROPER  POSITION  IN  TABLE 

80  \DT  = IDT  +INC 

IF  (YX  .GE.  TYX ( IDT ) ) GO  i j 80 
IDT  = IDT  -INC 

C INTERP  BETWEEN  TYX(IDT)  AND  TYX(IDT+INC) 

90  EVAL  = TEVAL(IDT)  + ( T EVAL  ( I OT  + INC  )- TEVAL  ( I DT)  ) 

1 / ( T Y X ( IDT ♦INC)— TYX( IDT) ) * ( YX- T YX ( I D T ) ) 

C SAVE  POSITION  IN  TaBLE 

INDEOG(J)  = IDT  -IFWAI 
GO  TO  110 

C INTERPOLATE  BETWEEN  T Y X ( L I M 2 ) AND  YX EDGI J+ 1 1 ♦ I NC ) /2 ) 

100  I = J ♦ ( 1 + INC  )/ 2 

DIV  = YXEOG(  I ) - TYXIL IM2) 

IF  (DIV  .EQ.  0. ) DIV  = 1. 

EVAL  = EVLECG(I)  ♦ (EVLECGI  I )-T EV  AL  ( L IM 2 ) ) /D  I V * I YX- YXEDG  ( I ) ) 
IDT  = L I M2 

C SAVE  POSITION  IN  TA3LE 

INDEDG(J)  = LIM2-1FWA1 

C AT  THIS  PCINT  EVAL  IS  BETWEEN  TEVAL(IDT)  AND  TEVALI  IDTMNC) 

C INCLUSIVE.  SET  LOCCT  SO  THAT  TEVAL ( LOCDT-1 ) .LE.  EVAL  .It. 

C TEVAL(LOCDT) 

110  LOCDT  = ICT  ♦ ( 1 + INC )/  2 
C SET  K INDEX  CORRESPONDING  TO  LOCDT 

LOCDTK  = LOCDT  -IFWA’ 

C SKIP  IF  THIS  IS  NOT  A TRANSVERSE  WAVE 

IF  (ITHWAV  .NE.  1)  GO  TO  120 
IF  (EVLEDG(J)  .EQ.  T EV  AL  ( I Fw  A 1 + 1 ) ) GO  TO  120 
C FOLLOWING  PROCEDURE  SHOULD  IMPROVE  ACCURACY  UF  EVAL  FOR  A 

C TRANSVERSE  WAVE.  FIRST  INTERPOLATE  FOR  RK,  DLDK  AS  FUNCTION  OF 

C EVAL 

C2  =■  ( EVAL-T  EV  AL  ( LOCDI  - 1 ))/(  TEVAL  ( LOCDT)-TEVAL  (LOCOT- 1 ) ) 

Cl  = 1.  -C2 

RK  = Cl *TK( LOCDTK-1 ) + C2* T< ( LOCDTK ) 

DLDK  = C1«TDLCK(L0CCT-1 ) + C 2* TCL DK( LOCDT ) 

T 1 = .5*RK«CLCK/EVAL 

TEMP  = • 5* ( 1 ,-Tl ) /YX  •( 1.- SQRT( 1.-4.*T1*(YX/(1.-T1) )**2) ) 

EVAL  = (T£MP**2  + 1.  )/B3DSPU**2 
C FORCE  THIS  TO  BE  WITHIN  KNOWN  LIMITS 

IF  (EVAL  .LT.  T EV  AL(  LOCDT- 1 ) ) EVAL  = TE  VAL  ( LOC  0 T- 1 ) 

IF  (EVAL  . GT  . T EV  AL ( LOCDT ) ) EVAL  = TEVAL ( LOCDT) 

C 

120  RETURN 
END 

SUBROUTINE  SPFUNCl JEDGE ) 


1 
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no  oo  on  oooooo  oooo  ooo 


COMPUTE  ST  AT  I CNARY  PHASE  FUNCTIONS 

COMMON  /BODY/  I BODY  , IPBOOY,  BODDEP,  BODDIA,  B03LEN,  BUDSPO 
It  RBSEP2.  RBSTR,  RBLIM 

complex  xdep,  fsrc 

COMMON  //  RK,  EVAL,  DL0<,  D2L,  PSIO,  DPSIOt  DPS1B,  WAKl,  SUPT 
It  YX,  03  L » XI,  ETA,  INRANG,  MODt , MINMOD,  MAXMOD,  MODES 

2,  MAXK,  IFWA1,  LOCDT,  LDCDTK,  ITHWAV,  NWAVES,  N WF  TAB  ( 41  ) 

3,  HILO,  CYX , PYX,  POYX,  PEVAL,  PRK,  FAZ,  SGNFZ2  , F A Z2 

4,  FAZ3,  XCEP,  FSRC , VAR,  SIGNAL,  SIGCUT(BOO) 

EQUIVALENCE  ( T EMP1 , S I GCUT ) 

DI  MENS  ION  T EMP  1(9,  j. ) 


X AND  Y COMPONENTS  OF  WAVE  NUMBER  RK 

XI  = RK/ ( OODSPD#SQRT( EVAL ) ) 

ETA  = SQRT  ( RK#*2-X 1**2 ) 

SOME  TEMPORARIES 
D1  = DLDK*RK/EVAL 
02  = U2L*RK**«_/EVaL 
T1  = ( X 1/ ET  A ) **2 
T 2 = XI/RK 

D ( X I ) / DK  AND  C(  ETAI/DK 

XII  = T 2 * ( 1 .-.5*01 ) 

ET  A 1 = ETA/RK  * i 1 . ♦ . 5*  T 1*0  1 ) 

D2IXD/CK2  ANC  D2IETAI/DK2 
XI 2 = -.5*T2/RK  *( C2+D1*(2.-1.5#D1)  ) 

ETA2  * . 5 *T  2 **2/ ET  A *( 02+0 1* ( 2 .-0 1* I 2 . ♦ . 5* T 1 ) ) ) 

SKIP  IF  PHASE  FUNCTION  AND  ITS  DERIVATIVES  ARE  REQUIRED 
IF  (JEDGE  .EG.  0)  GO  TD  10 

ROUTINE  IS  BEING  USED  AS  PART  OF  THE  PROCESS  UF  FINDING  WAVE 
FAMILY  EDGES.  COMPUTE  STATIONARY  PHASE  POINT  YX=D I XI ) /D I E T A ) AND 
D(YX)/D(EVAL)=C(YX)/DK  *D(  K ) /O  I EV AL  ) 

YX  = XI1/ETA1 

DYX  =■  ( ETA1#XI2-X  I 1*ETA2)/ET  Al»#2  /DLDK 
RETURN 

10  C3  = 03L#RK##3/EVAL 

D3IXD/DK3  ANC  D3I  ETAI/DK  3 

X I 3 = - . 5 *T  2/  RK  **Z  *(  03+02*1  3.-4. 5*01  ) + D 1**  2*  (-4.5+3.711*01  ) ) 

ET  A3  = .5*T2**2/( ETA*RK ) * ( 0 3 + D2* ( 3 .- ( 6.  + 1 . 5*Tl ) *C1  ) 

1 +Dl**2*(  -6.-1.5*Tl+(6.  + 3.*Tl  + .75*Tl**2)*Dl)  ) 

PHASE  FUNCTION 
FAZ  = XI  - XI1/ETA1  *E T A 
D2  (FAZ  )/D(  ETAI2  AND  D3  ( FAZ  )/ D I E T A ) 3 
FAZ2  = ( ET A1*X  I2-X  I1*ETA2)/ETA1**3 

F A Z3  = (ETA1*(  ETAl*Xl3-3.*ETA2*XI2-Xll*ETA3)  + 3.*XIl*ETA2**2) 

1 /t  TA i**5 

RETURN 
END 

SUBROUTINE  SPSRC 
COMPUTE  SOURCE  FUNCTION  FSRC 

COMMON  /BOCY/  IBOOY,  IPBOOY,  BODDEP,  BODDIA,  BOOLEN , BODSPD 
It  RBSEP2,  RBSTR,  RBLIM 

C 

COMMON  /GRID/  OBSDEP,  NOBS,  DOBS,  OBSMAX,  TABOBS(IOO),  ITHOBS 

1,  X,  LX,  XM  IN,  NX,  ITHX,  Y,  DY , YMIN,  NY,  I THY,  MOOE1,  MODEN 

2,  IVAR,  IPRDT , IPPDT19),  XPMAX,  Y PM AX , IPPPSD,  IPREDG 

3,  ISPHAS 
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COMMON  /SUPER/  ISUPR,  SUPTOP,  SUPBOT,  IPSUPR,  SUSTR  , SUSEP2 
It  SUPMIC,  SULIM,  SJPDIA,  SUPLEN 

C 

COMMON  /WAKE/  IWAKE,  CWAKR,  CWAKX,  XWAKE , WAKRAD,  XWNOM 
It  RESLVS,  CWAKM 

C 

COMPLtX  XDEP,  FSRL 

COMMON  //  RK,  EVAL,  DLDK,  C2L , PSIO,  DPSIO,  DPSIB,  WAKI,  SEPT 
1»  YX,  D3L,  XI,  ETA,  INRANG,  MODE,  MINMOD,  MAXMOD,  MODES 

2,  MAXK,  IFWA1,  LUC DT , LDCDTK,  ITHWAV,  NWAVES,  \IWFTA3(41) 

3t  HILO,  DYX,  PYX,  PUYX,  PEVAL,  PRK , FAZ,  SUNFZ2,  F A Z 2 

**  FAZ3,  XCEP,  FSRC,  VAR,  SIGNAL,  SIGCUT(BOO) 

EQUIVALENCE  ( T FMP 1, S IGC JT ) 

CIMENS  ION  TEMPI!  9,  I) 

C 

C 

FSRC  = (0.,  0. ) 

C SKIP  IF  BCDY  OFF 

IF  ( I BODY  .EQ.  0)  GO  TO  100 
IF  ( IBODY  .EC.  2)  GO  TO  20 
C RANKING  BODY 

C R BST  R=  S CU  RCt  STRENGTH,  RBSEP2=l/2  SOURCE  TO  SINK  SEPARATION 

FSRC  = CMPLX ( 0 . , -2 . *RBSTR *DPS I R*S  IN ( XI*RBSEP2 ) ) 

GO  TO  100 

C DIPOLC  BODY.  RBL IM=L I M ( Rrt STR *R BSEP 2 ) 

20  FSRC  = CMPLX ( 0 . , -2 . *RBL IM *DPS  I 8*X  I ) 

C 

C SKIP  IF  WAKE  IS  OFF 

100  IF  (IWAKE  .EQ.  0)  GO  TO  200 
C SKI P I F WAKE  NOT  ON  YCT 

IF  (X  .LT.  XWAKE)  GO  TO  200 

FSRC  = FSRC  + W AKI *CMPLX( -COSI X I*XWAKE  ) , S I N I X I * X WA KE ) ) 

C 

C SKIP  IF  SUPERSTRUCTURE  IS  OFF 

200  IF  (ISUPR  .EQ.  0)  GO  TO  300 
IF  (ISUPR  .EC.  2)  GO  TO  220 

C CVAL  SUPERSTRUCTURE.  SJSTR=SOURCE  STRENGTH,  SUSEP2=l/2  SOURCE 

C TO  SINK  SEPARATION,  SJ PT =P S 1 1 BOT  )-P S I ( TOP  ) 

TEMP  = 2 . *SUSTR*SUPT  *S  I NI  X I*  SUSEP2  ) 

C SUPMIU  = X CCURDINATE  OF  MICCLE  OF  SUPF  < STRUCTURE 

FSRC  = FSRC  ♦ TEMP*CMPi_X(  S IN(X  I*SUPMID)  , CO  S(  XI  * SUPMI  D ) ) 

GO  TO  300 

C CIRCULAR  SUPER.  SUL  I M =L I MI  SU STR* SUSEP2 ) 

220  TEMP  = 2.  *SULIM*SUPT*X  I 

FSRC  = FSRC  + TEMP*CMPLX(  S INIX I*SUPMID) , CO S ( X I # SUPMI D ) ) 

C 

300  RETURN 
END 

SUBROUT  INE  S PV  AR 

C COMPUTE  THE  VARIABLE-DEPENDENT  (BUT  SOURCE- INDEPENDENT)  PART 
C OF  THE  SIGNAL,  THEN  PUT  EVERYTHING  TOGETHER 

C 

COMMON  /BODY/  I BODY , IPBODY,  BODDEP , BDUDIA,  BUDLEN,  BODSPD 
It  RBS  t P2  t RBSTR,  RBLIM 

C 

COMMON  /GRIC/  OBSDEP,  NORSt  CORSt  OBSMAXt  TABOBS(IOO),  ITHOBS 
1 » X,  XMIN,  NX t ITHXt  Y,  DY,  YM I N t N Y t ITHY,  MODE  1 , MODEN 

2t  IVAR,  IPRDT , IPPDT  ( 9 ),  XPMAX,  YPMAX,  IPPPSD,  I PRCDG 

3 1 ISPHAS 

C 

COMPLEX  XDEP,  FSRC 

COMMON  //  RK,  EVAL,  DLD<,  D2L , PSIO,  D>SIO,  DPSIB,  WAKI,  SUPT 
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1,  YX,  03 L , XI,  ETA,  INRANG,  MODE,  MINMOD,  MAXM3D,  MODES 

2,  M.^XK,  IFWAI,  LOCDT,  LDCDTK,  ITHWAV,  NWAVES,  NWFTABIM) 

3,  HILO,  DYX,  PYX,  PDYX,  PEVAL,  PRK , FAZ,  SGNFZ2,  FAZ2 

4,  F AZ  1 , XDEP,  FSRC,  VAR,  SIGNAL,  SI3LJTI  800) 

EQUIVALENCE  U EMP 1 , S IGCUT ) 

DIMENS ICN  T EMP  1 ( 9,  1) 

C 

C 

TEMP  = 2 .*XI*(  2.*RK/DLDK*(  ET  A/ ( BOD  SP  D*  X I**  2 ))*  * 2 + 1 . ) 

TEMP  = (2./ ABS  (X«FAZ3)  )**(  1./3  . ) /TEMP 
GO  TO  ( 10,20, 30, 40, 50, '60, 70,  80, 90,  100), I VAR 
C 

C (U)  DOWNTRACK  VELOCITY  DISTURBANCE 

10  VAR  = CnS  10  « X 1/ KK  * *2 
GO  TO  200 
C 

C (V)  CROSS  TRACK  VELOCITY 

20  VAR  = UPSIC  * ET  A/  RK  **  2 
GO  TO  200 
C 

C .DELTA-X)  DOWN  TRACK  DISPLACEMENT 

30  VAR  = DPSIO  /(  RODS  PC  *RK  **2  ) 

GO  TO  210 
C 

C (DELTA-Y)  CROSS  TRACK  DISPLACEMENT 

40  VAR  = DPSIO  * ET  A/  ( PODS PC*X I *RK ** 2 ) 

GO  TO  210 
C 

C (OELTA-Z)  VERTICAL  DISPLACEMENT 

50  VAR  = -PS  10  / ( BODS  PC*X  I ) 

GO  TO  200 
C 

C (EPSILON-X)  COWN  TRACK  STRAIN 

60  VAR  = DPSIO  * X 1/ ( 8CDSPD*KK**2  ) 

GO  TO  200 
C 

C (EPSILON-Y)  CROSS  TRACK  STRAIN 

70  VAR  = DPSIO  • ETA**2/(  BUCSPO*X  !*RK**2> 

GO  TO  200 
C 

C (GAMMA-XY)  SHEARING  STRAIN  IN  HORIZONTAL  PLANE 

80  VAR  = DPSIO  * 2 . * ET  A/  ( BODS  PD  *RK  * * 2 ) 

GO  TO  200 
C 

C (SIGMA)  HORIZONTAL  PL  AN  E 0 IL  AT  AT  ION 

90  VAR  = -CPS IC 
GO  TO  210 
C 

C (W)  VERTICAL  VELOCITY 

100  VAR  = PSIC 
GO  TO  210 
C 
C 

C PUT  IT  ALL  TOGETHER 

200  SIGNAL  = SIGNAL  ♦ T EMP* VAR*R E AL ( F SRC* XDEP ) 

RETURN 

210  SIGNAL  = SIGNAL  + TEMP*VAR*A IMAGI  FSRC«XDEP ) 

RETURN 

END 

SUBROUTINE  SPWFAM 

C CONSTRUCT  WAVE  FAMILY  EDGE  TABLES  AND  TABLE  OF  STATIONARY  PHASE 
C POINTS  (-Y/X) 
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COMMON  / BOOY  / I BODY  , I P BODY , BODDEP,  BODOIA,  3UDLEN,  BOOSPD 
1»  RB5EP2,  RBSTR,  RBLIM 

COMMON  /CONST/  JDK,  JDMODL,  JLT'.L,  PI,  NULL,  JUCKL,  JDMF  T 

1,  JOCKS  V,  J QMS  P,  JDEDGt 

COMPLEX  XCEP,  FSRC 

COMMON  //  RK,  EVAL,  OLD*,  D2L , PSIO,  DPSIQ,  DPSIB,  WAKI,  SUPT 
1*  YX,  D3L , XI,  ETA,  INRANG,  MODE,  M I JMOD , MA  XMOO , MODES 

2,  MAXK,  I f to  A 1 , LOCDT , LOCDTK,  ITHWAV,  NWAVES,  NWFTAB141) 

3 , HILL,  CYX,  PYX,  PDYX,  PEVAL,  PRK,  FAZ,  SuNF  Z 2 , FAZ2 

4,  FAZ3,  XCEP,  FSRC,  VAR,  SIGNAL,  SIGCUT(BOO) 

EQUIVALENCE  ( f EM P * , S I Gf JT ) 

DIMENSION  T EM  P 1 ( 9 , 1 ) 

COMMON  //  TK(IOO),  T EV  A _ ( 1 00 , 4 1 ) , TUL 0< ( ICO , 41 ) , TD  2 L ( i 00  ,41) 

1,  TPS 10( 100,41  ) , TDPSIOI  100,41),  TDP S I B I 1 00, 4 1 ) , T WA K I (100,41) 

2,  TSUPT ( 100,41),  T Y X ( 1 00, 4 1 ) , YXEDGl  2C, 41 ) , E VL ED  3 ( 2 0 ,41 ) 

3,  LIMEDGI 20, 41  ),  I NDEDGI  20, 41 ) 


CALL  T I MER ( 16) 

SQUIN  = l./BCCS?D**2 
MODE  = MAXMOC 

START  LOOP  THROUGH  ALL  MODES  FROM  MAX  TO  MIN 
GET  FWA-1  OF  THIS  MODE  IN  DI  SP  TABLES 
10  IFWA1  = ( MODE- 1 ) * J OK 

CHECK  FCR  (TRANSVERSE  WAVE),  (CRITICAL  SPEED),  (DIVERGING  WAVE) 
IF  (TEVAL(  IFWA1+U-SQJIN)  50,  20,  40 
20  WRITE! 6 ,30 ) BODSPO 

30  FORMAT (54H  STATIONARY  PHASE  INADEQUATE, 

1 E13.6) 

CALL  EPRXIT 


BODY  AT  CRITICAL  SPEED= 


DIVERGING  WAVE. 

SET  VALUE  OF  -Y/X  ANC  ITS  DERIVATIVE  WR T EVAL 
40  YX  = 1 ./SQRT(TEVAL( IFWA1  + 1 )*B0DSPC»»2-1.  ) 

DYX  = -1.5 *B0DSPD**2  *YX**3 

EIGENVALUE  ANC  WAVENUMBER  CORRESPONDING  TO  YX 
EVAL  = T EV  AL  ( I Fto  A i ♦ 1 ) 

RK  = T K ( 1 ) 

INDEX  OF  NEXT  TABLE  POINT 
LOCDTK  = 2 

FILL  IN  1ST  ENTRY  OF  STATIONARY  PHASE  POINT  TABLE  (NOT  USED, 
BUT  LOOKS  NICE  ON  PRINT  OF  DISP  TABLES) 

TYXUFWAl  + l)  = YX 

THIS  EDGE  IS  A MAX  OF  YX.  SET  FLAG  TO  LOOK  FOR  A MIN 
HILO  = 1. 

GO  TO  90 

TRANSVERSE  WAVE.  FIND  INNER  EDGE  (AT  E VAL  = 1 /BOD  SPD*  *2  ) 

50  DO  60  LOCDTK*  1,  MAXK 
LOCOT  = IFWAl+LOCDTK 

PUT  0 IN  STATIONARY  PHASE  POINT  TABLE  SO  PRINT  WILL  LOOK  NICE 
T YX ( LOCDT ) = 0. 

60  IF  (TEVAULOCCT  ) .GT.  SQUIN)  GO  TO  8C 

1ST  EDGE  IS  BEYONO  RANGE  OF  DISP  TABLE.  ALSO  SKIP  LOWER 
MODES — THtY  ARE  WORSE  CASES 
MINMOD  = MODE  + l 

IF  (MINMOC  .LE.  <M AXMOD ) GO  TO  13C 
WRITE ( 6 ,70 ) 

70  FORMAT ( 3 1H  MAX(K)  IN  DISP  TABLE  TOO  SMALL) 
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CALL  ERRXIT 

C SET  VALUE  OF  -Y/X  AT  INNER  EDGE 

80  YX  = 0. 

C FAKE  0(YX)/D(£VAL) . ( Y X=0  IS  AN  ABSOLUTE  MINIMUM  SO  LOGIC  TO 

C FIND  EXTRtMA  WILt  NEVER  USE  CYX  I 

DYX  - 1. 

C EIGENVALUE  and  WAVENUMBER  CORRESPONDING  TO  YX 

EVAL  = SQUIN 

RK  = TKILCCCTK-1)  + ( T K I LOCDTK l-TK ILOCDTK- 1 ) ) 

1 / (T.VALILOCDT  I-TlVALILOCDT-1)  ) * ( E VA  L - TE  VAL  I LOC  J T-l  )) 


THIS  EDGE  IS 
HILO  = -1. 


A MIN  OF  YX.  SET  FLAG  TO  LOOK  FOR  A MAX 


INSERT  1ST  EDGE  DATA  INTO  EDGE  TABLtS 
90  YXEDGI 1 .MODE ) = YX 
EV  LEDG ( 1 » MODE ) = hVAL 
C SET  D.T.  INDEX  OF  1ST  POINT  BEYOND  EDGE  AND  PRESET  POSITION 

C SAVER  lUStU  BY  SPt.VAL) 

L' MEDGt l.MODE)  = LOCDTK 
I NDEDG ( 1 , KQOE ) = LOCDTK 

C INITIALIZE  COUNT  OF  NJMBER  OF  WAVE  FAMILIES 

NWAVES  = 1 
C 

C LOOP  FOR  REMAINING  TABLE  POINTS 

L I M = LOCDTK 

CO  100  LGCCTK  = LIN.MAXK 
C SAVE  PAST  VALUES  JF  YX , DYX,  EVAL,  RK 

PYX  = 

PDYX  = DYX 
PEVAL  = EVAL 
PRK  = RK 

C CT  ADDRESS  CCRRESPGNCI NG  TO  LOCDTK 

LOCDT  = IFWA1  ♦ LUCDTK 

C PICK  UP  RK,  EVAL,  D(EVAL)/D<,  D2IEVAII/DK2  AT  CURRENT  TABLE  POINT 

RK  = TK( LOCDTK  ) 

EVAL  = T EV  AL ( L OCDT ) 

DLDK  = TDLDKI  LOCDT  ) 

C2L  = T D2  L ( LCD  DT  ) 

C COMPUTE  STATIONARY  PHASE  POINT  YX  AND  D ( YX ) /D ( E VAL ) 

CALL  SPFUNCI  1) 

C FILL  IN  TABLE  OF  YX 

TYXILOCDT*  = YX 

C TEST  FOR  AND  FIND  WAVE  FAMILY  EDGE ( S ) BETWEEN  PAST  AND  CURRENT 

C POINTS 

CALL  SPEDGE 
100  CONTINUE 

C SKIP  IF  LAST  POINT  IN  D.T.  IS  NOT  AN  EDGE 

IF  ITYX(LCCDT)  .NE.  YX EDG( NW AV ES ) ) GO  TO  110 
C NUMBER  OF  WAVE  FAMILIES  IS  1 LESS  THAN  NUMBER  OF  EDGES 

NW  AV  ES  = NW  AV  ES  -1 
GO  TO  120 

C USE  LAST  POINT  OF  D.T.  AS  AN  EDGE 

110  YXEDG(NWAVES+1,M00E)  = YX 

EVLEDG  ( NW  AV  ES  ♦ 1,  MOCE  ) = EVAL 
LIMEDGI NWAVES+l.MODE ) = MAXK 
INDEDG!NWAVES+1,M0CE)  = MAXK 

C SET  UP  TABLE  OF  NUMBER  OF  WAVE  FAMILIES  IN  EACH  MODE 

120  NWFTAB(MOCE)  = NW  AV  ES 
C 

MODE  = MOCE  -1 

IF  (MODE  .GE.  MINMOC)  GO  T3  10 
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130  CALL  T IMLRl -16  ) 

RETURN 

END 

SUBROUTINE  SPXOEP 
C X DEPENCENCC  OF  SIGNAL 

C 

COUPON  /GPIC/  OBSCEP,  NOBS,  COBS,  OBSMAX,  TABOBS(IOO),  ITHOBS 

1,  X,  UX,  XMINf  NX,  ITHX,  Y,  DY , YMIN,  NY,  ITHY,  M00E1  , MODEN 

2,  1VAR,  IPRDT,  IPPDTI9),  XPMAX,  YPMAX,  IPPPSD,  IPRCDG 

3,  IS  PH  AS 

c 

COMPLEX  XDEP,  FSRC 

COMMON  //  RK,  EVAL,  DLD<,  D2L,  PSIO,  D^SIO,  DP  SI  3 , WAKI,  SUPT 

1,  YX,  03  L , XI,  ETA,  INRANG  * MODE,  MINMOD,  MAXMOD,  MODES 

2,  MAXK , I FW  A 1 , LOCDT,  LOCDTK , ITHWAV,  NWAVfcS,  NWFTABK1) 

3,  HILO,  DYX , PYX,  P DYX , PEVAL,  PRK , FAZ,  SGNFZ2  , FAZ2 

A,  FAZ3,  XCEP,  FSRC,  VAR,  SIGNAL,  SISCUT1800) 

EQUIVALENCE  ( T EMP1 , S IGCUT  ) 

DIMENSION  TEMP1I9,  1) 

COMPLEX  CA I RY , EXP  I B 
C 
C 

C NEGATIVE  CF  AIRY  FUNCTION  ARGUMENT 

A = FAZ2**2  *(  .5*X/FAZ 3**2 )•*( 2./3. ) 

C GET  AIRY  FUNCTIONS  AIRY  A = A II  -A  ) AND  A IR  YB  =B  I ( - A ) 

CALL  AIRY!  A I RY  A,  AIRYB,  -A) 

C SET  UP  COMPLEX  FORM  OF  AIRY  FUNCTION 

CAIRY  = CMPLXI  AIRY  A,  A I RYB*SGNFZ2 ) 

C 

B = X • ( F AZ  +FAZ2**3/(3.*FAZ3*«2)) 

EX  PI  B = CMPLX  ( COS  ( B ) , S INI  BH 
C 

XDEP  = CA I RY •LX  P I B 

RETURN 

END 

SUBROUTINE  SPIPNT 

C COMPUTE  SIGNAL  AT  FIELD  POINT  DEFINED  3Y  X,  YX=-Y/X,  OBSDEP 

C 

COMPLEX  XCEP,  FSRC 

COMMON  //  RK,  EVAL,  DL D< , D2L,  PSIO,  DPSIO,  DPSIB,  WAKI , SUPT 

1,  YX,  03L , XI,  ETA,  INRANG,  MODE,  MINMOD,  MAXM03,  MODES 

2,  MAXK,  IFWA1,  LOCDT,  LOCDTK,  ITHWAV,  NWAVES,  NWFTAB(Al) 

3,  HILO,  CYX , PYX,  PDYX,  PEVAL,  PRK,  FAZ,  SGNFZ2,  FAZ2 

A,  FAZ3,  XDEP,  FSRC,  VAR,  SIGNAL,  SIGCUTI600) 

EQUIVALENCE  ( T EMP  I, S IGC JT ) 

DIMENSION  TEMP1I9, I) 

C 

c 

call  T IMERI 17) 

C -SIGNAL-  IS  RUNNING  SUM  OF  CONTRIBUTION  FROM  EACH  MODE  AND 

C WAVE  FAMILY 

SIGNAL  = 0. 

C LOOP  FOR  EACH  MODE 

00  20  MOC  E=  M I NMOQ,  MAX  MOD 

C PICK  UP  NUMBER  OF  WAVE  FAMILIES  FOR  THIS  MODE 

NWAVES  = NWFTAB(MOOE) 

DO  10  ITHWAV=1,  NWAVES 

C INTERPOLATE  IN  OISPERSION  TABLES  AT  STATIONARY  PHASE  POINT 

CALL  SPDISP(O) 

C SKIP  IF  YX  IS  OUTSIDE  THE  RANGE  OF  THIS  WAVE  FAMILY 
IF  (INRANG  .EQ.  0)  GO  TO  10 

C COMPUTE  XI,  ETA,  PHASE  FUNCTION  FAZ  AND  ITS  DERIVATIVES  FAZ2,FAZ3 
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CALL  S PFUNCI 0 ) 

C COMPUTE  X DEPENDENCE  OF  SIGNAL  CXDEP) 

CALL  SPXDEP 

C COMPUTE  SOURCE  FUNCTION  (FSRC) 

CALL  SPSRC 

COMPUTE  VARIABLE-DEPENDENT  PART  OF  SIGNAL,  COMBINE  Ml TH  XDEP, 
FSRC  AND  ADD  IT  INTO  -SIGNAL- 
CALL  SPVAP 
10  CONTINUE 
20  CONTINUE 

CALL  T IMERI-17 ) 

RETURN 
END 

SUBROUTINE  T R I D( C, A, B, D,X , N,  MSF ) 

LAST  MOO  I F I CAI  ION  3/22/ 68-K . E .M  . 

TRID  IS  A TR I -01  AGONAL  MATRIX  LINEAR  EQUATION  SOLVER. 

IF  MX=  D IS  SUCH  AN  EQJATION,  THEN  THE  I TH  ROM  OF  M I S 

MllDI0,0,...f0,C<  I), All), BCD, 0... .,0,0),  WHERE  C ( 1 > =B  ( N)  =0.  C 
C,A,B,D  ANO  X APE  VECTORS  OF  LENGTH  N 
MSF=0  IF  M IS  NUNS INGJL AR 
= 1 IF  M IS  SINGULAR 
Cl  mens  I CN  C«N),A(N).B(N>,D(N),X(N) 

NN=N 
RM=NN-I 

c scale  rcws 

DO  30  I = 1 , NN 

T=  AMAX 1 ( ABS  ( A(  ID  , ABSI  B(  I ) ).  ABS(  C (I)  ) > 

IFIT)  120,120,20 
20  A( I D Al II/T 
Bl  IDBI I )/T 
CII)=C(  D/T 

30  oddoid/t 
c eliminate 

DO  90  1=1, NM 

IF  I ABS  I A(  I ) I -ABS  I C ( DID)  60,40,tC 
♦0  IF  I AD  ) ) 50,120,50 
50  C(D  = A(I) 

AlIDBlI) 

B(  11=0.0 
GO  TO  BO 

60  IFICID1D  70,  120,70 
70  CIIKIIMI 
Cl  D1)*A(  1 I 
All  DAI  Dll 
AID1DBI  D 
8(D  = BtDl) 

Bl  D1)*0.0 
T-DID 
01 1)  = OI  Dl) 

DID1DT 

BO  T«CID1)/CID 

Al  Dl  I = A(  D1)-T*AI  I) 

Bl  D1DBI  DD-T«B(  I) 

90  D(D1)*DID1)-T«D(  D 

C BACK  SUBSTITUTE 

IFIAINND  100,  120,100 
100  XINNDDIKM/AINN) 

XI NMJ»  IDINM|-A|NM)«XINND/C|  NM  I 

00  110  J«2, NM 

I-NN-J 

110  XI  IDIDI  D-AI  IDXI  Dil-Bl  I DXl  D2II/CII) 

C normal  EXIT 

ist 


oooooooooooooooooooooooonoonnooooooooooooooooooo 


MS  F =0 
RETURN 

C S I NGULAK  MAT  RIX  EX  IT 

120  MS  F = 1 

RETURN 

END 

SUBROUTINE  F lb  I ( NM,  N,  T , D,  E , E 2,  IERR) 

C 

INTEGtR  l , N*NM  » I ERR 
REAL  T (NM,3),D(N),E(N),  £2(N) 

REAL  SORT 

GIVEN  A NUNSYMMETR IC  TRIDIACONAl  MATRIX  SUCH  THAT  THE  PRODUCTS 
CF  CORRES PCNCI NG  PAIRS  OF  OFF-DIAGONAL  ELEMENTS  ARE  ALL 
NON-NEGAT  IVt,  THIS  SUBROUTINE  REDUCES  IT  TO  A SYMMETRIC 
TRIUIAGCNAL  MATRIX  WITH  THE  SAME  EIGENVALUES.  IF,  FURTHER, 

A ZERO  PRUDUCT  ONLY  OCCURS  WHEN  BOTH  FACTORS  ARE  ZERO, 

THE  REDUCED  MATRIX  IS  SIMILAR  TO  THE  ORIGINAL  MATRIX. 

CN  INPUT- 

NM  MUST  BE  SET  TO  THE  ROW  DIMENSION  OF  TWO-DIMENSIONAL 
ARRAY  PARAMETERS  AS  DECLARED  IN  THE  CALLING  PROGRAM 
DIMcNSIGN  STATEMENT, 

N IS  THE  ORDER  OF  THE  MATRIX, 

T CONTAINS  THE  INPJT  MATRIX.  ITS  SUBDIAGONAL  IS 

STORED  IN  THE  LAST  N- 1 POSITIONS  OF  THE  FIRST  COLUMN, 

ITS  C I AGONAL  IN  THE  N POSITIONS  OF  THE  SECOND  COLUMN, 

AMD  ITS  SUPEKDIAGONAL  IN  THE  FIRST  N-l  POSITIONS  OF 
THE  THIRD  COLUMN.  T<  1,  1)  AND  TIN, 3)  ARE  ARBITRARY. 

CN  OUT  PUT - 

T IS  UNALTERED, 

D CONTAINS  THE  DIAGONAL  ELEMENTS  OF  THE  SYMMETRIC  MATRIX, 

E CONTAINS  THE  SUBDIAGONAL  ELEMENTS  OF  THE  SYMMETRIC 
MATRIX  IN  ITS  LAST  N-l  POSITIONS.  Ell)  IS  NOT  SET, 

E2  CONTAINS  THE  SQJARES  OF  THE  CORRESPONDING  ELEMENTS  OF  E. 
E2  MAY  COINCIDE  WITH  E IF  THE  SQUARES  ARl  NOT  NEEDED, 

IERR  IS  SET  TO 

ZERO  FOR  NORMAL  RETURN, 

N+I  IF  T ( 1 , 1 )*  Tt  1-1,3)  IS  NEGATIVE, 

-C-*N  + I)  IF  T(I,i)*T(  7-1,3)  IS  ZERO  WITH  ONE  FACTOR 

NON-ZERO.  IN  THIS  CASE,  THE  EIGENVECTORS  OF 
THE  SYMMETRIC  MATRIX  ARE  NOT  SIMPLY  RELATED 
TO  THOSE  OF  T AND  SHOULD  NOT  BE  SOUGHT. 

QUESTIONS  AND  COMMENTS  SHOULD  BE  DIRECTED  TO  B . S.  GARBOW, 
APPLIED  MATHEMATICS  DIVISION,  ARGONNE  NATIONAL  LABORATORY 


IERR  = 0 

DO  100  I = 1,  N 

IF  (I  .EC.  1)  GO  TO  90 
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E2 ( II  = T ( 1,1)  * T ( 1-1, 3) 

IF  ([2(1)1  1000,  60,  eo 

IF  ( T ( 1 , 1 ) .EQ.  0.0  .AND.  T I 1-1*31  .EO.  C.O)  GO  TO  30 
C «•*„#«•••  SET  ERROR  — PRODUCT  OF  SOME  PAIR  OF  OFF-DIAGONAL 

C ELEMENTS  IS  ZERO  WITH  ONE  MEMBER  NUN-ZERO  *••**•• 

I ERR  = -(3  * N ♦ I ) 

80  E(I)  = S GRT ( E2 ( I)  ) 

90  D( I ) = T ( 1,2) 

100  CONTINUE 
C 

GO  TO  100. 

C SET  ERROR  — PRODUCT  OF  SOME  PAIR  OF  OFF-DIAGONAL 

C ELEMENTS  IS  NEGATIVE  «#•••••••• 

1000  I ERR  = N ♦ I 

1001  RETURN 

C LAST  CARC  OF  FICI  •••••***** 


END 

SUBRCUT INt  RATOR(N, EPSl.D, E,  E2,M,W, 1ND.3D, TYPE ,IDEP  ,IERR) 

C 

INTEGER  I , J,K,M,N,  II, JJ,K1, ICEF, I ERR, JDEF 
REAL  D(N),E(N),E2(N),W(N),BD(N) 

REAL  F,  P,  R,S  , EP.GP,  ERR,  TOT  , EP  S 1,  DEL  TA  , MACHtP 
C REAL  ABS.AMINi 

INTEGER  I NC ( M ) 

LOGICAL  TYPE 

THIS  SUBROUTINE  IS  A TRANSLATION  OF  THE  ALGOL  PROCEDURE  RATQR, 
NUM.  MATH.  11,  26*-272( 1968)  BY  REINSCH  AND  BAUER. 

HANDBOOK  FOR  AUTO.  COMP.,  VO  L . I I-L  I NEAR  ALGEBRA,  25  7-2  e.5  (1  97 1 ) . 

THIS  SUBROUTINE  FINDS  THE  ALGEBRAICALLY  SMALLEST  OR  LARGEST 
EIGENVALUES  CF  A SYMMETRIC  TRIDIAGONAL  MATRIX  BY  THE 
RATIONAL  CR  METHOD  WITH  NEWTON  CORRECTIONS. 

CN  INPUT- 

N IS  THE  ORDER  OF  THE  MATRIX, 

E PS  1 IS  A THEORETICAL  ABSOLUTE  ERROR  TOLERANCE  FOR  THE 

COMPUTED  EIGENVALUES.  IF  THE  INPUT  EPSi  IS  NON-POSITIVE, 
OR  INDEED  SMALLER  THAN  ITS  DEFAULT  VALUE,  IT  IS  RESET 
AT  EACH  ITERATION  TO  THE  RESPECTIVE  DEFAULT  VALUE, 

NAMELY,  THE  PRODUCT  OF  THE  RELATIVE  MACHINE  PRECISION 
ANC  THE  MAGNITUDE  OF  THE  CURRENT  EIGENVALUE  ITERATE. 

THE  THEORETICAL  ABSOLUTE  ERROR  IN  THE  K-TH  EIGENVALUE 
IS  USUALLY  NOT  GREATER  THAN  K TIMES  EPSi, 

D CONTAINS  THE  DIAGONAL  ELEMENTS  OF  THE  INPUT  MATRIX, 

E CONTAINS  THE  SUBDIAGONAL  ELEMENTS  OF  THE  1NPLT  MATRIX 
IN  ITS  LAST  N-l  POSITIONS.  E(l)  IS  ARBITRARY, 

E2  CONTAINS  THE  SQUARES  OF  THE  CORRESPONDING  ELEMENTS  OF  E. 
E2 ( 1 ) IS  ARBITRARY, 

M IS  THE  NUMBER  CF  EIGENVALUES  TO  BE  FOUND, 

I DEF  SHOULD  BE  SET  TO  1 IF  THE  INPUT  MATRIX  IS  KNOWN  TO  BE 
POSITIVE  DEFINITE,  TO  -l  IF  THE  INPUT  MATRIX  IS  KNOWN  TO 
BE  NEGATIVE  DEFINITE,  AND  TO  0 OTHERWISE, 

TYPE  SHOULD  BE  SET  TO  .TRUE.  IF  THE  SMALLcST  EIGENVALUES 
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ARE  TO  BE  FOUND,  AND  TO  .FALSE.  IF  THE  LARGEST  EIGENVALUES 
ARE  TO  RE  FQJNC . 


CN  OUT  PUT - 

EPS  1 IS  UNALTEREC  UNLESS  IT  FAS  BEEN  RESET  TO  ITS 
(LAST)  DEFAULT  VALUE, 


0 AND  E ARc  UNALTERED  (UNLESS  W OVERWRITES  0), 

ELEMENTS  OF  E 2 , CORRESPONDING  TO  ELEMENTS  OF  E REGARDED 
AS  NEGLIGIBLE,  HAVE  BEEN  REPLACED  BY  ZERO  CAUSING  THE 
MATRIX  TO  SPLIT  INTO  A CIRECT  SUM  OF  SUBMATRICES. 

E2(l>  IS  SET  TO  0.0  IF  TFE  SMALLEST  EIGENVALUES  HAVE  BLEN 
FOUND,  AND  Td  2.0  IF  THE  LARGEST  EIGENVALUES  HAVE  BEEN 
FOUND.  F 2 IS  OTHERWISE  UNALTERED  (UNLESS  OVERWRITTEN  BY  BD), 


W CONTAINS  THE  M ALGEBRAICALLY  SMALLEST  EIGENVALUES  IN 
ASCENDING  ORDER,  OR  THE  M LARGEST  EIGENVALUES  IN 
DESCENDING  ORDER.  IF  AN  ERROR  EXIT  IS  MADE  BECAUSE  OF 
AN  INCORRECT  SPECIFICATION  OF  IDEF , NO  EIGENVALUES 
ARE  FOUND.  IF  THE  NEWTON  ITERATES  FOR  A PARTICULAR 
EIGENVALUE  ARE  NOT  MONOTONE,  THE  BEST  ESTIMATE  OBTAINED 
IS  RETURNED  AND  IERR  IS  SET.  W MAY  COINCIDE  WITH  D, 


IND  CONTAINS  IN  ITS  FIRST  M POSITIONS  THE  SUBMATRIX  INDICES 
ASSOCIATED  WITH  THE  CORRESPONDING  EIGENVALUES  IN  W — 

1 HOR  EIGENVALUES  BELONGING  TO  THE  FIRST  SUBMATRIX  FROM 

THE  T G° , 2 FOR  THOSE  BELONGING  TO  THE  SECOND  SUBMATRIX,  ETC., 


BD  CONTAINS  REFINED  BOUNDS  FOR  THE  THEORETICAL  ERRORS  UF  THE 
CORRESPONDING  EIGENVALUES  IN  W.  THESE  BOUNDS  ARE  USUALLY 
WITHIN  THE  TOLERANCE  SPECIFIED  BY  FPS1.  BD  MAY  COINCIDE 
WITH  E2, 


IERR  IS 
ZERO 
6 »N+ 1 


5 »N-*-K 


SET  TO 

FOR  NORMAL  RETURN, 

IF  IDEF  IS  SET  TO  1 AND  TYPE  TC!  .TRUE. 
WHEN  THE  MATRIX  IS  NOT  POSITIVE  DcFINITE,  OR 
IF  IDEF  IS  SET  TO  -1  AND  TYPE  TO  .FALSE. 
WHEN  THE  MATRIX  IS  NOT  NEGATIVE  DEFINITE, 

IF  SUCCESSIVE  ITERATES  TO  THE  K-TH  EIGENVALUE 
ARE  NOT  MONOTONE  INCREASING,  WHERE  K REFERS 
TO  THE  LAST  SUCH  OCCURRENCE, 


NOTE  THAI  SUBROUTINE  T 3L I OR  IMTQL  1 IS  GENERALLY  FASTER  THAN 
RATQR,  IF  MORE  THAN  NM  EIGENVALUES  ARE  TO  BE  FOUND.  ALSO, 
BISECT  IS  GENERALLY  FASTER  IF  THE  EIGENVALUES  ARE  ^LUSTERED. 

QUESTIONS  ANC  COMMENTS  SH3ULC  BE  DIRECTED  TO  B.  S.  3ARB0W, 
APPLIED  MATHEMATICS  DIVISION,  ARGONNE  NATIONAL  LABORA.URY 


MACHEP  IS  A MACHINE  DEPENDENT  PARAMETER  SPECIFYING 
THE  RELATIVE  PRECISION  OF  FLOATING  POINT  ARITHMETIC. 


MACHEP  = 2. **(-47) 

(ERR  = 0 
JOEF  = IDEF 
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C **********  COPY  0 ARRAY  INTO  W ********** 

DO  20  I = l,  N 
20  Mil)  = D(I) 

C 

IF  (TYPE)  GC  TO  40 
J = 1 
GO  TO  400 
40  ERR  = 0.0 
S = 0.0 

•»•••»••••  LOOK  for  small  sub-diagonal  entries  and  define 

INITIAL  SHIFT  FROM  LOWER  GERSCHGORIN  BOUND. 

COPY  E2  ARRAY  INTO  BD  ********** 

TUT  = W ( 1 ) 

0 = 0.0 

J = 0 

c 

CU  100  I = 1,  N 
P = Q 

IF  (I  .EC.  1)  GO  TO  60 

IF  (P  .GT.  MACHEP  * (ABS(Oil))  ♦ A B Si  D ( I - 1 ) ) ) ) 30  TO  80 
60  E2  ( I ) = 0.0 
J = J + 1 

80  BD ( I ) = E2 ( I ) 

INDi  I ) = J 
C = 0.0 

IF  (I  .NE.  N)  Q = ABSiEi  1 + 1)  ) 

TOT  = AMINliWi  I )-P-0,T0T) 

100  CONTINUE 
C 

IF  (JDEF  .EQ.  1 .AND.  TOT  .LT.  0.0)  GO  TO  140 
C 

co  no  i = l,  n 
no  win  = win  - tot 
c 

GO  TO  160 
140  TOT  * 0.0 

c 

160  D(J  3bO  K = 1,  M 


C ••••••••••  NEXT  QR  TRANSFORMATION 

180  TOT  = TOT  + S 


DELTA  = WiN)  - S 
I = N 

F = ABS ( MACHEP*TOT ) 

IF  ( EPS  1 .LT.  F)  EPS  1 = F 
IF  (DELTA  .GT.  EPS1)  GO  TO  190 
IF  (DELTA  .LT.  (-EPSD)  GO  TO  1000 
GO  TO  300 


C **********  REPLACE  SMALL  SUB-DIAGONAL  SQUARES  BY  ZEPO 

C TO  REDUCE  THE  INCIDENCi:  OF  UNDERFLOWS  ********** 

190  IF  (K  .EQ.  N)  GO  TO  210 

K1  = K + 1 
DO  200  J = Xlt  N 

IF  (BDiJi  .LE.  ( M ACHEP  *(  W(J)+W(J-1M)  **  2)  BD  i J ) = 0.0 

200  continue 

c 

210  F = BD(N)  / DELTA 

QP  = DELTA  + F 
P = 1 .0 

IF  (K  .EC.  M GO  TO  260 
K1  - N - K 

C ••••••••••  FOR  I=N-1  STEP  -1  UNTIL  K DO  — •••••••••• 

DO  240  II  = l,  K 1 
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I = N - II 
Q = W( I ) - S - F 

r = e / qp 

P = P * R + 1.0 
EP  = F * R 
W(  l + l ) = OP  + EP 
DELTA  = Q - EP 

IF  (DELTA  .GT.  EP  SI ) GO  TO  220 
IF  (DELTA  .LT.  (-EPS  1)1  GO  TO  1000 
GO  TO  300 
F = 8 D ( I ) / 0 
QP  = DELTA  * F 
BE ( I +1  ) = CP  * EP 
CONT  INUE 

W ( K ) = QP 
S = CP  / P 

IF  (TOT  + S .GT.  TOT)  GO  TO  180 

* SET  ERROR  --  IRREGULAR  END  OF  ITERATION. 

DEFLATE  MINIMUM  DIAGONAL  ELEMENT  *#*#**< 
I ERR  = 5 • N + K 
S = 0.0 
DELTA  = CP 


DO  280  J = K,  N 

IF  (W(J)  .GT.  DELTA)  GO  TO  280 
I - J 

DElTA  = W(J) 

CONTINUE 

CONVERGENCE  ##**«*•**• 

IF  (I  .LT.  N)  B D ( I + 1 ) = BD(  I ) * F / 3P 
II  = I NO ( I ) 

IF  (I  .EC.  K)  GO  TO  340 
K1  = 1 - K 

* FOR  J = I-1  STEP  -1  UNTIL  K DO  -- 

DO  320  JJ  = 1.  K 1 
J = I - JJ 
W( J + l ) = W(  J ) - S 
BD(J+1)  = BD( J ) 

I NO ( J + 1 ) = INO(J) 

CONTINUE 


W ( K ) = TOT 

ERR  = ERR  + ABS(DELTA) 

BD( K ) = ERR 
IND(K)  = II 
CGNTINUl 

IF  (TYPE)  GO  TO  1001 
F = BD( 1) 

E2(l)  = 2.0 
80(1)  = F 
J * 2 

* NEGATE  ELEMENTS  3F  W FOR  LARGEST  VALUES 

DO  500  I = 1,  N 

win  = — w < i ) 


1000 

1001 


JDEF  = -JDEF 
GO  TO  (40.1001),  J 

**•••***••  SET  ERROR  --  IOEF  SPECIFIED  INCORRECTLY 

I ERR  = 6 * N ♦ 1 

RETURN 
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c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 

c 


LAST  CARr  3 F RATQR 


END 


SUBROUT  I ME  T INV  I T ( NM,  N,  D»  E,  E2,  M,W,  IND,  Z , 

X IERR,  RVl,RV2,RV3,kV<*,RV6) 


I NTEGfcR  I,J,M,N,P,Q,R,S,II,IP,JJ,NM,ITS,TAG,IERR,GROUP 
REAL  D(N),E(N),E2(N),W(M),Z(NM,M), 

X RV1  (N)  ,RV2(N),RV3<N),RV4(N),RV6(N) 

REAL  U,V,  UK,  XU,  XOt  XI,  EPS2.  EPS  3,  EPS*, NORM,  ORDER  , MAC  HEP 
REAL  SORT  , ABS  t FLOAT 
INTEGER  I N C ( M ) 


THIS  SUBROUTINE  IS  A TRANSLATION  OF  THE  INVERSE  ITERATION  TECH- 
M CUE  IN  THE  ALGOL  PROCEDURE  TRISTUhM  BY  PETERS  AND  HI  LKI  NSCN. 
HANDBOOK  FOR  AUTO.  COMP.,  VOL  . I I-L 1 N EAR  ALGEBRA,  *1 8- *39 ( 1 971 ) 


THIS  SUBROUTINE  FINDS  THOSE  EIGENVECTORS  OF  A TRIDIAGONAL 
SYMMETRIC  MATRIX  CORRESPONDING  TO  SPECIFIED  EIGENVALUES, 
USING  INVERSE  ITEKAT  ION. 


CN  INPUT- 


NM  MUST  BE  SET  TG  THE  ROW  DIMENSION  OF  TWO-DIMENSIONAL 
ARRAY  PARAMETERS  AS  OECLARED  IN  THE  CALLING  PROGRAM 
DIMENSION  STATEMENT, 


N IS  THE  CRDER  OF  THE  MAIRIX, 


0 CONTAINS  THE  DIAGONAL  ELEMENTS  OF  THE  INPUT  MATRIX, 


E CONTAINS  THE  SU  BU I AGONAL  ELEMENTS  OF  THE  INPUT  MATRIX 
IN  ITS  LAST  N-l  POSITIONS.  l(1)  IS  ARBITRARY, 


E2  CONTAINS  THE  SQUARES  OF  THE  CORRESPONDING  ELEMENTS  OF  E, 

WITH  ZERCS  CORRESPONDING  TO  NEGLIGIBLE  ELEMENTS  OF  E. 

Eli)  IS  CONSIDERED  NEGLIGIBLE  IF  IT  IS  NOT  LARGER  THAN 
THE  PRODUCT  UF  THE  RELATIVE  MACHINE  PRECISION  AND  THE  SUM 
OF  THE  MAGNITUDES  OF  D(I)  AND  D(I-l).  E 2 C 1 ) MUST  CONTAIN 
0.0  IF  THE  EIGENVALUES  ARE  IN  ASCENDING  ORDER,  OR 
2.0  IF  THE  EIGENVALUES  ARE  IN  DESCENDING  ORDER. 

IF  BISECT  OR  RATOR  HAS  BEEN  USED  TO  FIND  THE  EIGENVALUES, 
THEIR  OUTPUT  E2  ARRAY  IS  EXACTLY  WHAT  IS  EXPECTED  HERE, 


M IS  THE  NUMBER  OF  SPECIFIED  EIGENVALUES, 

W CONTAINS  THE  M EIGENVALUES  IN  ASCENDING  Uk  LESCENDING  ORDER, 


IND  CONTAINS  IN  ITS  FIRST  M POSITIONS  THE  SUBMATRIX  INDICES 
ASSOCIATED  WITH  THE  CORRESPONDING  EIGENVALUES  IN  W -- 
1 FOR  EIGENVALUES  BELONGING  TO  THE  FIRST  SUBMATRIX  FROM 
THE  TOP,  2 FUR  THOSE  BELONGING  TO  THE  SECOND  SUBMATRIX,  ETC. 


CN  OUT  PUT - 

ALL  INPUT  ARRAYS  AR  6 UN  AL  T ER  ED, 


Z CONTAINS  THE  ASSOCIATED  SET  OF  ORTHONORMAL  EIGENVECTORS. 
ANY  VECTGR  WHICH  FAILS  TO  CONVERGE  IS  SET  TO  ZERO, 


I ERR  IS  SET  TO 

ZERO  FOR  NORMAL  RETURN, 

-R  IF  THE  EIGENVECTOR  CORRESPONDING  TO  THE  R-TH 
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EIGENVALUE  FAILS  TO  CONVERGE  IN  5 ITERATIONS, 


RV1,  RV 2,  RV3 , RV4,  AND  RV6  ARE  TEMPORARY  STORAGE  ARRAYS. 


QUESTIONS  AND  COMMENTS  SHOULD  BE  DIRECTED  TO  B . S.  GARBOW, 
APPLIED  MATHEMATICS  DIVISION,  ARGONNE  NATIONAL  LABORATORY 


MACHEP  IS  A MACHINE  DEPENDENT  PARAMETER  SPECIFYING 
THE  RELATIVE  PRECISION  OF  FLOATING  POINT  ARITHMETIC, 


MACHEP  = 2.**( ~47 ) 


I ERR  = 0 
TAG  = 0 

CRDER  = 1.0  - E2( I ) 

C = 0 

..........  ESTABLISH  AND  PROCESS  NEXT  SUBMATRIX 

100  P ■ Q ♦ 1 


DO  120  Q = P,  N 

IF  (Q  .EG.  N)  GO  TO  140 
IF  (E21Q+1)  .EO.  0.0)  GO  TO  140 
120  CONTINUE 

.,•••*•***  find  vectors  by  inverse  iteration 

140  TAG  = TAG  ♦ 1 
S = 0 


DO  920  R = 1,  M 
IF  (INC(R)  .NE. 
ITS  = 1 
XI  = W ( R ) 

IF  (S  .NE.  0)  GO 

***** CHECK  FO 

XU  = 1.0 

IF  (P  .NE.  Q)  GO 
RV61P)  = 1.0 
GO  TO  870 
NORM  = ABS ( D( P ) ) 
IP  = P ♦ l 


.NE.  TAG)  GO  TO  920 


GO  TO  510 

FOR  ISOLATEC  ROOT 


GO  TO 


DO  500 
NORM  = 


I = IP,  Q 

NORM  ♦ ABS  ( D(  I ) ) + ABStEC  I I I 
t EPS  2 IS  THE  CRITERION  FOR  GROUPING, 

EPS 3 REPLACES  ZERO  PIVOTS  AND  EQUAL 
ROOTS  ARE  MOD  IF  IE  C BY  EPS3, 

EPS4  IS  T A<  EN  VERY  SMALL  TO  AVOID  OVERFLOW 


EPS 2 = l.OL-3  * NORM 
EPS 3 = MACHEP  * NORM 
UK  = FLOAT !Q-P+1) 

EPS 4 = UK  « EPS  3 
UK  = EPS4  / SQRT(UK) 

S = P 
GROUP  = 0 
GO  TO  520 

••«««•«•  LOOK  FOR  CLOSE  OR  COINCIDENT  ROOTS 
IF  (ABS(Xl-XO)  .GE.  EPS2)  GO  TO  505 
GROUP  = GROUP  + 1 

IF  (ORCER  * (XI  - XO)  .LE.  0.0)  XI  = XO  ♦ 


ORDER  « EPS3 


ELIMINATION  WITH  INT ERCHANGF. S AND 


INITIALIZATION  OF  VECTOR  ********** 

V = 0.0 

00  5 80  I * P,  (J 
RV6 ( I ) = UK 

IF  (I  .EG.  P ) GO  TO  560 
IF  (ABSIEim  .LT.  A OS  ( U ) ) GO  T(J  540 
•••••••  WARNING  --  A DIVIDE  CHECK  MAY  OCCUR  HERE  IF 

E2  ARRAY  HAS  NOT  BEEN  SPECIFIED  CORRECTLY  ***** 
XU  = U / E ( I ) 

RV4  ( I ) ^ XU 
RV 1 ( I - 1 ) = HI) 

R VZ ( I - 1 ) = 0(1)  - XI 
RV3  ( I-I  ) = 0.0 

IF  ( I ,NE.  0 ) RV3(  I-  1)  = E ( I + 1 ) 

J = V - XU  » RV  2 ( I - 1 ) 

V = -XU  * RV  3(  !-l  ) 

GC  TC  580 

XU  = E ( I ) / U 

RV4 ( I ) - XU 

R V 1 ( I - 1 > = U 

RV2U-1)  = V 

KV  3 ( 1-1 ) = 0.0 

U=D(I)-X1-XJ*V 

IF  ( I . N E . Q)  V = E(  1+1) 

CONT  I NUE 

IF  (U  .EG.  0.0)  U = EPS3 
RV1(Q)  = U 
RV2(C)  = 0-0 
RV  3 ( G ) = 0.0 

««  BACK  SUBSTITUTION 

FCR  I = Q STEP  -1  UNTIL  P DD  --  ***** 

DO  620  II  = P,  G 
I « P ♦ Q - II 

RV6  ( I ) = ( RV  6 ( I ) - U * R V 2(  I ) - V * RV3(I))  / RVl(I) 

V = U 

U = RV6(  I ) 

CONT  I NUE 

*******  ORT  HOGUNAL  IZ  E WITH  RESPECT  TO  PREVIOUS 
MEMBERS  OF  GROUP  ********** 

IF  (GRCUP  .EQ.  0)  GO  TO  700 
J = R 

DO  680  JJ  = 1,  GROUP 
J = J - 1 

IF  (IND(J)  .NE.  TAG)  GO  TO  630 
XU  = 0.0 

DC  640  I = P,  Q 

XU  = XU  ♦ RV  6(  I ) * Z ( I , J ) 

DO  660  I = P,  Q 

RV6( I ) = RV6(  I ) - XU  * Z(  I, J) 

CONT  I NUE 

NORM  = 0.0 

DC  720  I = P,  g 

NORM  = NORM  ♦ A BS ( R V 6 ( I ) ) 


ooooo  o o o o o o o o no  n o o o o 


r t 

u 


IF  (NORM  .GE . 1.0)  GO  TO  840 

C ••«•«•••••  FORWARD  SUB  ST  ITUT  ION  *«••«*•**• 

IF  (ITS  .EG.  5)  GO  TO  830 
IF  (NORM  .NE.  0.0)  GO  TO  ?<*0 
RV6 ( S ) = EPS4 
S = S ♦ 1 

IF  (S  .GT.  Q)  S = P 
GO  TC  780 

740  XU  = EPS4  / NORM 

c 

00  760  I = P,  Q 
760  RVo ( I ) = RV6(  I ) • X J 

C ELIMINATION  OPERATIONS  ON  NEXT  VEoTUR 

C ITERATE  **«#•**••• 

780  DO  820  I = IP,  Q 

U = RV  6 ( I ) 

IF  RV 1 ( I - 1 ) .fcO.  E ( I ) , A ROW  INTERCHANGE 

WAS  PERFORMED  EARLIER  IN  THE 

T R I ANGU  L AR  I Z AT  ION  PROCESS  * 

IF  (RVl(I-l)  .NE.  E(  I ) ) GO  TO  8C0 
U = RV6 ( 1-1 ) 

RV6 ( 1-1 ) = RV  6 ( I ) 

800  RV6  ( I ) = U - RV4(I>  * RV  6 ( I-  1 ) 

820  CONTINUE 


ITS  = ITS  ♦ I 
GO  TO  600 

••••••••••  SET  ERROR  — NON-CONVER GED  EIGENVECTOR 

830  I ERR  = -R 

XU  = 0.0 
GO  TO  870 

NORMALIZE  SO  THAT  SUM  OF  SQUARES  IS 

1 AND  EXPAND  TO  FULL  ORDER  •*•*••••*• 

840  U = 0.0 


860 

DO  860  I 
U = U ♦ 

* P,  Q 
RV6 ( I )*#2 

XU  = 1.0 

/ SQRT(U) 

870 

880 

DO  880  I 
Z ( I » R ) = 

* It  N 
0.0 

900 

DO  900  I 
Z ( I , R ) = 

* P*  o 

RV 6 ( I ) » XU 

920 

XO  = XI 
CONTINUE 

IF  (Q  .LT.  N)  GO  TO  100 
RETURN 

••••••••••  LAST  CARC  OF  TINVIT 

END 

SUBROUTINE  BAKV EC ( NM , N , T , E , M , Z , IERR  ) 


INTEGER  I, J,M,N,NM,  IERR 
REAL  T (NM,3) , E ( N ) , Z ( NM , M ) 


THIS  SUBROUTINE  FORMS  THE  EIGENVECTORS  OF  A NO  NSYMME  TRIC 
T R I DI  AGONAL  MATRIX  BY  BACK  TRANSFORMING  THOSE  OF  THE 
CORRESPONDING  SYMMETRIC  MATRIX  DETERMINED  BY  FIGI. 


j 


\ 
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CN  INPJT- 

NM  MUST  BE  SET  TC  THE  RCJW  DIMENSION  OF  TWO-DI  MlN  SI  ONAL 
ARRAY  PARAMETERS  AS  DECLARED  IN  THE  CALLING  PROGRAM 
DIMENSION  STATEMENT 

N IS  THt  ORDER  OF  THE  MATRIX, 

T CONTAINS  THE  NONSYMMETKIC  MATRIX.  ITS  SUBDIAGONAL  IS 
STORED  IN  THE  LAST  N- 1 POSITIONS  3F  THE  FIRST  COLUMN, 
ITS  DIAGONAL  IN  THE  N POSITIONS  OF  THE  SECOND  COLUMN, 
ANO  ITS  iUPE1'.  DIAGONAL  IN  THE  FIRST  N- 1 POSITIONS  OF 
THE  THIRD  COLUMN.  T(l,l)  AND  TIN, 3)  ARE  ARBITRARY, 

E CONTAINS  THE  SUBDIAGONAL  ELEMENTS  OF  THE  SYMMETRIC 
MATRIX  IN  ITS  LAST  N- 1 POSITIONS.  Ed)  IS  ARBITRARY, 

M IS  THE  NUMBER  OF  EIGENVECTORS  TO  BE  BACK  TRANSFORMED, 

Z CONTAINS  THE  EIGENVECTORS  TO  BE  BACK  TRANSFORMED 
IN  ITS  FIRST  M COLUMNS. 

CN  CUT  PUT - 

T IS  UNALTERED, 

E IS  DESTROYED, 

Z CONTAINS  THE  TRANSFORMED  EIGENVECTORS 
IN  ITS  FIRST  M COLUMNS, 


I ERR  IS  SET  TO 

ZERO  FOR  NORMAL  RETURN, 

2 »N+ 1 IF  Eli)  IS  ZERO  WITH  Td,l)  OR  TlI-1,3)  NON-ZERO. 

IN  THIS  CASE,  THE  SYMMETRIC  MATRIX  IS  NOT  SIMILAR 
TO  THE  ORIGINAL  MATRIX,  AND  THE  EIGENVECTORS 
CANNOT  BE  FOUND  BY  THIS  PROGRAM. 

GUEST  I ONS  ^NC  COMMENTS  SHOULD  BE  DIRECTED  TO  b.  S.  GARBOW, 

APPLIED  MATHEMATICS  DIVISION,  ARGONNE  NATIONAL  LABORATORY 


IERR  = 0 

E11)  = 1.0 

IF  (N  . EQ.  1)  GO  TO  1001 

DO  100  I = 2,  N 

IF  (Eli)  .NE.  0.0)  GO  TO  80 

IF  ( T ( 1 , 1 ) .NE.  0.0  .OR.  T(  1-1,3)  .NE.  0.0)  GO  TO  1000 
E(I)  = 1.0 
GO  TO  100 

80  E(I)  = EII-11  » Ell)  / T(  1-1,3) 

100  CONTINUE 


00  i.20  J = 1,  M 

00  120  I = 2,  N 
Z(I,J)  = Z( I, J)  • Ell) 
120  CONTINUE 


GO  TO  1001 


oooooooooooooo 


c •••*••*•*•  SET  ERROR  --  EIGENVECTORS  CANNOT  BE 

C FOUND  BY  THIS  PROGRAM  ********** 

1000  IERR  = 2 * N + I 

1001  RETURN 

c ••*••«••••  LAST  card  of  bakvec  «**•#**•** 

END 

SUBROUTINE  FCU  RT  ( D AT  A,  NN,  N C I M , I S I GN,  I FORM,  WORK  I 
C 

C THE  COOLEY -TUI  EY  FAST  FOUR  ICR  TRANSFORM  IN  USA  SI  BASIC  FORTRAN 

C 

c TRANSFORM! J1 ,J2» ». f ) = SUM ( D AT  A ( I 1 , I 2 , , , , ) * W 1* * { ( I 2- 1 ) * ( J2 -1 ) ) 

C *W2**I  ( 12-1  )* ( J2-1  ))*,,,)  , 

C WHERE  II  AND  Jl  RJN  FROM  1 TO  NN(1>  AND  W1 =E XP ( I S I 0 N* 2 *P I = 

C SORT (-1 )/ NN( 1 ) ) , ETC.  THERE  IS  NO  LIMIT  ON  THE  DIMENSIONALITY 

C (NUMBER  CF  SUBSCRIPTS)  OF  THE  DATA  ARRAY.  IF  AN  INVERSE 

C TRANSFORM  <ISIGN=+1)  IS  PERFORMED  UPON  AN  ARRAY  OF  TRANSFORMfcU 

C (ISIGN--1)  DATA,  THE  ORIGINAL  DATA  WILL  REAPPEAR. 

C MULTIPLIED  BY  NN ( 1 ) *NN ( 2 ) * , , , THF  ARRAY  OF  INPUT  DATA  MUST  BE 

C IN  COMPLEX  FORMAT.  HQwEVFR,  IF  ALL  IMAGINARY  PARTS  ARE  ZERO  (I.E. 

C THE  DATA  ARE  DISGUISED  REAL)  RUNNING  TIME  IS  CUT  L'P  TO  FORTY  PER- 

C CENT.  (FOR  FASTEST  TRANSFORM  OF  REAL  DATA,  NN  ( 1 ) SHOULD  BE  EVEN.) 

C THE  TRANSFORM  VALUES  ARE  ALWAYS  COMPLEX  AND  ARE  RETURNED  IN  THE 

C ORIGINAL  ARRAY  OF  DATA,  REPLACING  THE  INPUT  DATA.  THE  LENGTH 

C CF  EACH  DIMENSION  OF  THE  DATA  ARRAY  MAY  BE  ANY  INTEGER.  THE 

C PROGRAM  RUNS  FASTER  ON  COMPOSITE  INTEGERS  THAN  ON  PRIMES,  AND  IS 

C PARTICULARLY  FAST  ON  NJMBhRS  RICH  IN  FACTORS  OF  TWO. 

C 

C TIMING  IS  IN  FACT  GIVEN  BY  THE  FOLLOWING  FORMULA.  LET  NTOT  BE  TH_ 

C TOTAL  NUMBER  UF  POINTS  (RLAL  OR  COMPLEX)  IN  THE  DATA  ARRAY,  THAT 

C IS,  NTOT=NN( 1 ) *NN( 2) * • . . DECOMPOSE  NTOT  INTO  ITS  PRIME  FACTORS, 

C SUCH  AS  2 • *K2  • 3 • *K  3 * 5**K5  * ...  LET  SUM2  BE  THE  SUM  DF  ALL 

C THE  FACTORS  OF  TWO  IN  NTOT,  THAT  IS,  SUM  2 = 2*K2.  LET  SUMF  BE 

C THE  SUM  OF  ALL  OTHER  FACTORS  OF  NTOT,  THAT  IS,  SUM'  = 3*K3*5*K5*.. 

C THE  TIME  TAKEN  BY  A MULTIDIMENSIONAL  TRANSFORM  ON  THtSE  NTOT  DATA 

C IS  T = TO  ♦ NTOT*! T 1 +T 2 *SUM2 *T3*SUMF ) . ON  THE  CDC  3300  (FLOATING 

C POINT  ADD  TIME  = SIX  MICROSECONDS),  T = 3000  ♦ NTOT* ( b00*40* SUM2+ 

C 17  5 *SU  MF ) MICROS  ECCNDS  ON  COMPLEX  DATA. 

C 

C IMPLEMENTATION  OF  TFE  DEFINITION  BY  SUMMATION  WILL  RUN  IN  A TIME 

C PROPORTIONAL  10  NT OT *( N N! 1 ) +NN ( 2 ) ♦ . . . ) . FOR  HIGHLY  COMPOSITE  NTOT 

C THE  SAVINGS  CFFERtC  BY  THIS  PROGRAM  CAN  BE  DRAMATIC.  A ONE-DIMEN- 

C SIGNAL  ARRAY  4000  IN  LENGTH  WILL  BE  TRANSFORMED  IN  4C00*(600+ 

C 40  * ( 2 + 2 + 2 + 2 + 2 ) +1 75  * ( 5 + 5 +5 ) ) = 14.5  SECONDS  VERSUS  ABOUT  4000* 

C 4000*175  = 2800  SECONDS  FJR  THE  STRAIGHTFORWARD  TECHNIQUE. 

C 

C THE  FAST  FOURIER  TRANSFORM  PLACES  THREE  RESTRICTIONS  UPON  THE 

C DATA. 

C 1.  THE  NUMBER  OF  INPJT  DATA  AND  THE  NUMBER  UF  TRANSFORM  VALUES 

MUST  BE  THE  SAME. 

2.  BOTH  THE  INPUT  DATA  AND  THE  TRANSFORM  VALUES  MUST  REPRESENT 
EQUISPACEC  POINTS  IN  THEIR  RESPECTIVE  DOMAINS  OF  TIME  AND 
FREQUENCY.  CALLING  THESE  SPACINGS  DELTAT  AND  DELTAF,  IT  MUST  BE 
TRUE  THAT  DtLTAF  = <:*PI/(NN(  I)*DcLTAT).  OF  COURSE,  0 E L TAT  NEED  NOT 
BE  THE  SAME  FOR  EVERY  DIMENSION. 

3.  CONCE  I TU  ALLY  AT  LEAST,  THE  INPUT  DATA  AND  THE  TRANSFORM  OUTPUT 
REPRFS  ENT  SINGLE  CYCLES  UF  PERIODIC  FUNCTIONS. 

THE  CALLING  SEQUENCE  IS  — 

CALL  FOURT (CAT  A,NN,NCIM, IS  ION,  I FORM, WORK  ) 

DATA  IS  THt  ARRAY  USED  TO  HOLD  THE  REAL  AND  IMAGINARY  PARTS 
OF  THE  DATA  ON  INPUT  AND  THE  TRANSFORM  VALUES  ON  OUTPUT.  IT 

169 


p* 


‘TV, 


C IS  A MULTIDIMENSIONAL  FLOATING  POINT  ARRAY , WITH  THE  REAL  AND 

C IMAGINARY  PARTS  Op  A DATUM  STORED  IMMEDIATELY  ADJACENT  IN  STORAGE 

C (SUCH  AS  FORTRAN  IV  PLACES  THEM!.  FORMAL  FORTRAN  ORDERING  IS 

C EXPECTEO,  THE  FIRST  SUBSCRIPT  CHANGING  FASTEST.  THE  DIMENSIONS 

C ARE  GIVEN  IN  THE  INTEGER  ARRAY  NN,  OF  LENGTH  NDIM.  I SIGN  IS  -I 

C TU  INDICATE  A FORWARD  TRANSFORM  (EXPONENTIAL  SIGN  IS  -)  AND  *1 

C FOR  AN  INVERSE  TRANSFORM  (SIGN  IS  + ).  I FORM  IS  U IF  THE  DATA  ARE 

C COMPLEX,  0 IF  THE  DATA  ARE  REAL.  IF  IT  IS  0,  THE  IMAGINARY 

C PARTS  OF  THE  DATA  MUS  BE  SET  TO  ZERO.  AS  EXPLAINED  ABOVE,  THE 

C TRANSFORM  VALUES  ARE  ALWAYS  COMPLEX  AND  ARE  STORED  IN  ARRAY  DATA. 

C WORK  IS  AN  ARRAY  USED  FDR  WORKING  STORAGE.  IT  IS  FLOATING  POINT 

C REAL,  ONE  DIMENSIONAL  OF  LENGTH  EQUAL  TO  TWICE  THE  LARGEST  ARRAY 

C DIMENSION  N\m  THAT  IS  NOT  A POWER  OF  TWO.  IF  ALL  NN  ( I ) ARE 

C POWERS  OF  TWO,  IT  IS  NOT  NEEOED  AND  MAY  BE  REPLACED  BY  ZERO  IN  THE 

C CALLING  SEQUENCE.  THJS,  FQ*  A ONE-DIMENSIONAL  ARRAY,  NN ( 1 ) ODD, 

C WORK  OCCUPIES  AS  MANY  STORAGE  LOCATIONS  AS  DATA.  IF  SUPPLIED, 

C WORK  MUST  NCT  HE  I HE  SAME  ARRAY  AS  DATA.  ALL  SUBSCRIPTS  OF  ALL 

C ARRAYS  BEGIN  AT  ONE. 

C 

C EXAMPLE  I.  THREE-DIMENSIONAL  FORWARD  FOURIER  TRANSFORM  OF  A 

C COMPLEX  ARRAY  DIMENSIONED  32  BY  25  BY  13  IN  FORTRAN  IV. 

C DIMENSION  DAT A(32,25,  13),WORK(  5C),NN( 3) 

C COMPLEX  DATA 

C DATA  NN/32,25, 13/ 

C DO  1 1=1,32 

C DO  1 J= 1 , 25 

C DO  l K= 1 , 1 3 

C 1 DATA( I ,J,K)=CCMPLfcX  VALUE 
C CALL  FOURT  (CAT  A,NN, 3,-1,  1,  WORK  ) 

C 

C EXAMPLE  2.  ONE-DIMENSIONAL  FORWARD  TRANSFORM  DF  A REAL  ARRAY  OF 

C LENGTH  64  IN  FORTRAN  II, 

C DIMENSION  CAT  A ( 2 , 64 ) 

C DO  2 1=1,64 

C C AT  A ( 1 , I ) = RE AL  PART 

C 2 DAT  A (2 , I )=0. 

C CALL  FOURT  (CAT  A,64,  1,-1, 0,  0) 

C 

C THERE  are  no  ERROR  MESSAGES  OR  ERROR  HALTS  IN  THIS  PROGRAM.  THE 

C PROGRAM  RETURNS  IMMEDIATELY  IF  NDIM  OR  ANY  NN ( I ) IS  LESS  THAN  ONE. 

C 

C PROGRAM  BY  NORMAN  BRENNER  FROM  THE  BASIC  PROGRAM  BY  CHARLES 

C RADER,  JUNE  1967.  THE  IDEA  FOR  THE  DIGIT  REVERSAL  WAS 

C SUGGESTED  BY  2 AL  PH  ALTER. 

C 

C THIS  IS  THE  FASTEST  AND  MOST  VERSATILE  VERSION  OF  THE  FFT  KNOWN 

C TO  THE  AUTHOR.  A PROGRAM  CALLED  FOUR 2 IS  AVAILABLE  THAT  ALSO 

C PERFORMS  THE  FAST  FOURIER  TRANSFORM  AND  IS  WRITTEN  IN  USASI  BASIC 

C FORTRAN.  IT  IS  ABOUT  ONE  THIRO  AS  LONG  AND  RESTRICTS  THE 

C DIMENSIONS  OF  THE  INPUT  ARRAY  (WHICH  MUST  BE  COMPLEX)  TO  BE  POWERS 

C OF  TWO.  ANOTHER  PROGRAM,  CALLED  F0UR1,  IS  ONE  TENTH  AS  LONG  AND 

C RUNS  TWO  THIRDS  AS  FAST  ON  A ONE-DIMENSIONAL  COMPLEX  ARRAY  WHOSE 

C LENGTH  IS  A POWER  OF  TWO. 

C 

C REFERENCE  — 

C IEEE  AUDIO  TRANSACTIONS  (JUNE  1967),  SPECIAL  ISSUE  ON  THE  FFT. 

r 

DIMENSION  DATA(1),NN(1),IFACT( 32),WORK(l) 

DATA  T WOP  1/6. 283 18 5307 1796/,  R THL F /C . 7071 067811 8655/ 

I F ( ND I M- 1 ) 920 , l, 1 
1 NT  GT  = 2 

DO  2 I D I M= 1 ,ND IM 
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2 

C 

C 

C 


C 

c 

c 

5 


I 


10 

11 

12 


20 

30 


31 

32 


40 

50 

51 
60 

J 


, | 

1 

I F { NN(  IDIM ) 1920,920,  2 
NT  0T  = NT  OT  *NN ( IDIM) 

MAIN  LCCP  FOR  EACH  DIMENSION 


Nrn  = 2 

DO  910  I Cl  M=  1,  NO  IM 
N --NNI I HI  M) 

NP2=NP1»N 

IF ( N— 1 ) 920,900 ,5 

IS  N A POWER  OF  TWO  AND  IF  NOT,  WHAT  ARE  ITS  FACTORS 


M=  N 

NTWC=NP1 
IF  = 1 
I D I V=2 

I QUOT * M/  I D IV 

IREM=M-lCIV*IUUOT 

IF  ( IQU0T-IDIV)50,  11,  11 

I F ( IREMJ20, 12, 20 

NTWO=NTWO+NTWU 

I F ACT  ( I F ) = I C IV 

I F- I F+ 1 

M= I QUOT 

GO  TO  10 

IDI V=3 

I N0N2  = I F 

I QU0T=  M/ I D I V 

IREM=M-IDIV*IQUOT 

I F ( ICUOT-IGIV  )uO,  31,  31 

IF ( IREM)40,32, 40 

I F ACT ( I F ) = I D IV 

I F*  IF+ 1 

M= ICUOT 

GO  TO  30 

1 0 IV* I D IV ♦2 

GO  TO  30 

I N0N2= I F 

IF ( IKtM)60,51,60 
NTWO=NTWOfNTWU 
GO  TO  70 
I F ACT ( l F ) = M 


I 


SEPARATE  FOUR  CASES— 

1.  COMPLEX  TRANSFORM  OR  REAL  TRANSFORM  FOR  THE  4TH , 9TH , E TC . 
DIMENSIONS . 

2.  REAL  TRANSFORM  FOR  THE  2ND  OR  3RD  DIMENSION.  METHOD- 
TRANSFORM  HALF  THE  DATA,  SUPPLYING  THE  D THE R HALF  BY  CON- 
JUGATE SYMMETRY. 

3.  REAL  TRANSFORM  FOR  THE  1ST  DIMENSION,  N ODD.  METHOD- 
SET  THE  IMAGINARY  PARTS  TO  ZERO. 

4.  REAL  TRANSFORM  FOR  THE  1ST  DIMENSION,  N EVEN.  METHOD- 
TRANSFORM  A COMPLEX  ARRAY  OF  LFNGTH  N/2  WHOSE  REAL  PARTS 
ARE  THE  EVEN  NUMBEREO  REAL  VALUES  AND  WHL^E  IMAGINARY  PARTS 
ARE  THE  ODD  NUMBERED  REAL  VALUES.  SEPARATE  AND  SUPPLY 

THE  SECUND  HALF  BY  CONJUGATE  SYMMETRY. 


1 

I 


■ 


IC AS£=  1 
IF  MI  N=  i 
I1RNG=NP1 

IF( IDIM-4  171,100,100 
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I F ( I FORM ) 7 2, 72 , 100 
ICAS£=2 

I1RNG=NP0*( l+NPREV/2) 

IF  (IDIM-1 >73,73,100 

ICASE=3 

I1RNG=NP1 

I F ( NTWQ-NP  1 ) 100,100,  74 
I C ASE=4 
I F MI N=  2 
NTWC=NTW0/2 
N=  N/2 
NP2=NP2/2 
NT 0T  = NT  OT/ 2 
1 = 1 

DO  CO  J=i , NT  cr 
0 AT  A ( J ) = C AT  A( I ) 
i=I+2 

SHUFFLE  DATA  BY  BIT  REVERSAL,  SINCE  N=2+*K.  AS  THE  ShUFFLING 
CAN  BE  DOPE  PY  SIMPLE  INTERCHANGE,  NO  WORKING  ARRAY  If,  NEEDED 

IF(NTW0-NH2)200,  110,  110 

NP2  HF=  NP2/ 2 

J=1 

DO  150  I 2= 1 , NP2, NP 1 
IFIJ-I2) 120,130, 130 
I 1 M A X = I 2+NP1-2 
DO  125  Il=n,IlMAX,2 
DO  125  13= I 1,NT0T,NP2 
J3  = J+  I 3 - 1 2 
TEMPR=  D AT  A ( 13) 

TEMPI  = DAT  A(  13+1) 

DATA(I3)  = DAT  A ( J 3 ) 

CAT  A( I 3 + 1 ) = DAT  A(  J3  + 1) 

DAT  A ( J 3 ) = T EMPR 
DATA! J3+1 ) = T EMPI 
M=  NP2HF 

IF(J-M)  150,150,145 
J=  J-M 
M=  M/2 

i F ( M-NP1 ) 150, 140,  140 
J=  J + M 
GO  TO  300 

SHUFFLF  CATA  BY  DIGIT  REVERSAL  FOR  GENERAL  N 


NW0RK=2*N 

DO  270  11=1, NP1, 2 

DO  270  13=11, NT0T,NP2 

J=I3 

DO  260  I = 1 , NWORK , 2 
IF(ICASE-3)210,220,210 
WORK! I ) = DAT  A( J ) 

WORK! 1+1 ) = UAT  AIJ  + l ) 

GO  TO  230 
WORK! I ) = C AT  A ( J ) 

WORK! I + 1 ) =0 . 

?FP2=NP2 
I F= I FM  I N 

I F Pl  = I F P2/ I FACT ( IF) 

J---J  + IFP1 

IF(J-I3-IFP2)260,250,250 
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250  J=J-IFP2 
IFP2=  I n 1 
I F = I F+  1 

I F ( IFP2-NP1 >260, 260,  240 
260  CUNT  I NU C 

I2MAX  = I 3 + N P 2 - ^ PI 
1 = 1 

CO  270  12=  I 3,  1 2M AX  , NIP  1 
DATA)  12  ) = W 0 ft  K ( I ) 

DATA) 12+1 >=WCKK<  1+1 ) 

270  1=1+2 

C 

c MAIN  LOOP  FUR  FACTORS  OF  TWO.  PERFORM  FOURIER  TRANSFORMS  OF 

C LENGTH  FCU  R , rfITH  ONE  OF  LENGTri  TWO  IF  NEEDED.  T HF  TWIDDLE  FACTOR 

C W= EXPI  I 3 I GN*2*P l *SORT I - l )* M/ I 4*MMAX ) > . CHECK  FOR  W=  SIGN*  SORT  ( -1  ) 

C ANC  REPEAT  FOR  W = W * I 1+ I S I GN+ SQR T ( - 1 )) / S3 R T t 2 ) . 

C 

300  IFINTWC-NP1 >600,600, 305 
305  NP1TW=NP1+NP1 
I PAR=N'U0/NP1 

310  I F ( 1PAR-2 I 350, 330,  320 
320  I P AR= I P AR/ 4 
GO  TO  310 

330  CO  340  11=  1,  1 1RNG,  2 

DO  340  K 1 - I l.NTOT  ,N,  PIT  W 

K2=K1+NP1 

TE  MPR=  0 AT  A ( K 2 ) 

T EMP I = DAT  A ( K 2+  1 > 

DAT  A ( K2  ) = D AT  AIK.  i-TEMPR 
DAT  AIK2  + 1 ) = CAT  A I Kl +1 J-T  EMP I 
DATA(K1)  = UATA(K1  I+TEMPR 
340  CATAIKl+l )= DAT A(  K 1 + lI  + T EMP I 
350  MMAX^NPl 

360  IF(KMAX-NTW0/2)370, 600,600 

370  IMAX=MAX0(  NP1TW,  MMAX/? ) 

DO  570  L=NP1,LMAX,NP1TW 
M=  L 

IF ( MMAX -NP1 1420, 420, 380 
380  THETA=-T  WOPI « FLOAT  I L )/  FLOAT!  4 + MMAX  ) 

I F ( I S I GN ) 400  v 3P0, 390 
390  TH ET A=  -T HET  A 

400  WR=COS  (THET  A) 

W I =S I N ( THETA  ) 

410  W2R=WR*WR-W I *W I 
W2  1=2. *WR*W  I 
W3  R=W2  R*WR~W2  I *W  I 
W3I=W2R*WI+W21*WR 
420  DO  530  11=1, I 1RNG, 2 
kmin=u  + ipar*m 

IF ( MMAX -N PI  1430, 4 30,  440 
430  KMIN=U 
440  KDIF=IPAR*MMAX 
450  KS TEP=  4 *KD  I F 

IF (KSTEP-NTWC)460,460, 530 
460  00  520  K1=KKIN,NT0T,KSTEP 

K2=K1+KC I F 
K3  = K2+KUI  F 
K4  = K3  + KU I F 

IF  I MMAX -NP1 >470,470,48  0 
470  U1R=DAT  A( Kl ) +DAT  A{ K2 ) 

U1  I = 0ATA(K1  + 1)+DAT  A1K2+1) 

U2  R=  DAT  A(  K3  ) +D  AT  A<  K4  ) 
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U2  1=0 at  A(K3+1 ) + DAT  A ( K4  * 1 ) 

U3R=DATA(K1)-0ATA<K2) 

U3I=0AT  A(K1+1)-DATA(K2+1) 

I F ( IS  IGNI471, 472, 472 
U4R=DATAiK3+l>-0ATA<K4+l ) 

U4 I =DAT  A{K4)-DATA(K3) 

GO  TO  510 

U4R=DATA(K4+1)-DAT  AIK  3+1) 

U4I=DATA(K3)-LATA(K4 ) 

GO  TO  510 

T2R=W2R*DAT  A(K2)-W2I*DATA(  K2+1 ) 

T2  1=W2R*CAT  AIK2  + 1 ) +W2I»DATA<  K 2 ) 

T3  «=WR*CAT  A(K3  )-W  I*CATAII<  3 + 1 ) 

T 3 I=WR*CAT  A(  K3  + 1 )+W  I*DATA(  K3  ) 

T4R=W3R«LATA(K4)-w3I*DATA(  K9  + 1 ) 

T4I=W3R«CATA(K^+1)+W3 I * DAT  A ( K A ) 

U1 R = D AT  A ( K 1 ) +T  2R 
U1 I=DAT A(K1+1)+T2I 
U2  R=T3R+T4R 
U2 I =T  3 I +T  A I 
U3R=DATA(K1 ) -T  2 R 
U3 I=DAT  A ( K 1 + 1 ) -T 21 
I F ( 1SIGNK90, 300,500 
U4R=T3I-TM 
U9I =T4R-T3R 
GO  TO  510 
U4  R=  T A I -T  3 1 
U4I=T3R-T4R 
D AT  A ( K 1 )=IJ1R+U2R 
DATA(K1+1 )=U1I+U2I 
DAT  AIK2 )=U3R+U4R 
DAT  AIK2  + 1 )=U3I+U4I 
DATA(K3)=U1R-02R 
OAT  A ( K3  + 1 ) =U 1 1 -U  2 I 
DAT  A(K4)=U3R-U4R 
DAT AIKA+l )=U3I-U4I 
KO  I F=  KST  t P 
KM  I N=4  * ( KM  I N- 1 1J  + I1 
GO  TO  450 
CONT INJE 
M=  M+LMAX 

IF ( M-MMAX )540, 540, 570 

I F ( ISIGNJ550, 360,560 

T E M PR=  W R 

WR  = (WR+WI ) +RTHLF 

W I = (WI-TEMPR)#RTHLF 

GO  TO  410 

TEMPR=WR 

WR= (WR-WI ) *RTHLF 
WI= (TEMPR+WI ) * RT HL  F 
GO  TO  410 
CONTINJE 
I PA R=  3-1  PAR 
MMAX  = MMAX  + MMAX 
GO  TO  360 

MAIN  LOOP  FOR  FACTORS  NOT  EQUAL  TO  TWO.  APPLY  THE  TWIDDLE  FACTOR 
W = E X fM  I S I GN*2*PI  »SQRT  < - 1 ) * I J 1-  1 )* ( J 2-  J1 ) / UFpi  + 1 FP2  ) » , THEN 
PERFORM  A FOURIER  TRANSFORM  OF  LENGTH  I FACT  1 1 F ) , MAKING  USE  OF 
CONJUGATE  SYMMETRIES. 


I 3 


I F ( KTW0-NP2 )60  5, 700,  70  0 


i.  610  I F P2=  I FACT  ( IF)»Ii-Pl 

J1MIN=NP1+1 

I F I J1MIN-IFP1)615,  615,  640 


615  DO  635  J1=J1MIN, IFPl.MPl 

THETA=-TWOPI*HLOAT ( J 1- 1 ) /FLOAT*  IFP2) 
IF  ( ISIGM625,620,520 
620  THET  A=  -THET  A 
625  WSTPR=COS  (THE1  A) 

WSTPI=SIN(THET  A) 

WR=WST  PR 

Wl  = WST  PI 

JZMIN=J1+IFP1 

J.?  MAX= Jl+ IFP2- IFPi 

DO  635  J2=J2MIN, J2MAX, IFPI 

II MAX= J2+I lRNo-2 

DO  630  1 1=  J2 , UMAX, 2 

DO  630  J3=  1 1 ,NTOT , IFP2 

TEMPR=  DAT  A ( J 3 ) 

DATA!  J3  ) = D AT  A(  J3  )*WR-DATA(  J3  + 1 )*W  I 
630  DATA! J3+1 )=TEMPR*W  I +OAT  A( J 3+ 1 ) *WR 
TEMPR=WR 

WR=WR*WST  PR-W 1 *WST  P I 
635  Wl=TEMPR*WSTPI+W  I *WS TP  R 

640  THETA=-TWOPI/FLOAT  ( IFACTI  IF)  ) 

IF ( IS  I GN) 650,645 , 645 
;45  THET A=-THET  A 
650  WSTPR=COS  (THET  A) 

WST  PI  = S IN(THET  A) 

J2RNG=IFP1*( 1*1  FACT!  IF )/2) 

DO  645  11=1,11 RNG»2 
DO  695  13=11, NT0T.NP2 
J2MAX= 13+ J2RNG-I  FP1 
DO  690  J2=I3,J2MAX, IFPI 
J1 MAX= J2+IFP1-NP1 
DO  680  J1=J2, J1MAX.NP1 
J3MAX= J1+NP2-IFP2 
DO  680  J3= J1 , J3MAX , I FP2 
JMI N=J3-J2+I3 
JMAX= JMIN+ IFP2-IFP 1 
I=l+( J3-I3)/NP1HF 
I F ( J2-I3)655,655,665 
655  SUMR=0. 

SU  MI =0 . 

DO  660  J=JMIN,  JMAX,  IFPI 
659  SUMR=SUMR  + DATA  ( J ) 

660  SUMI  = SUMI+DATA(  J + l ) 

WORM  I ) =SUMR 
WORK ( I ♦ 1 ) =SUM I 
GO  TO  680 

665  IC  ON J= 1 + ( IFP2-2*J2  + I3+J3)/NP IFF 

J=  JMAX 

SUMR=DAT  A ( J ) 

SUM  I = D AT  A ( J + l ) 

CLDSR=0. 

OLDS  1 = 0 . 

( ) J=J-IFP1 

670  TEMPR=  SUMR 
TE  MPI  = SUM  I 


SUMR=TWOWR*SUMR-OL  DSR+DAT  A(  J ) 
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'V 


SJMI=TWOWR*SUMI-OLCS I + DATA( J +1  ) 

OLDS  R=  T EMPR 
CLDSI  = T EMP  I 
J= J-IFP1 

IF  ( J-JMINI675, 675,^0 
675  TE  MPR=  WR*StJMR~OL  DSR  + DAT  A(  J ) 

TF  M P I = W I *SU M I 

WORK! I ) =T  tMPR-T EMP I 

WORK! I C ON  J ) = T cMPR  + T CM? I 

Th  MPR=hR*SU  MI -OLDS  I+C  AT  A(  J +1  ) 

T t MPI  = W I *SUMR 
WORK! 1+1  ) = T EMP R +T  rMP I 
WORK! ICONJ  + 1 ) = T EMPR-TtMP I 
680  CONTINUE 

IF ( J2-l3)6rt5,o85»686 

685  WR=wSTPK 
WI =WSTPI 
GO  10  o90 

686  TE  M PR=  ml  R 
WR=WR*WSTPR-Wl*WSTPI 

WI =TEMPR«WST PI +W I*WSTPR 
690  TWOWR=  WR  + WR 

I - 1 

I2MAX*  I3  + NP2-NPI 
DO  675  12=  13,  I2MAX ,NP1 
CAT AII2  )=WORK(  I ) 

DAT  A( k 2 + 1 ) =WCRK I 1*1) 

695  1=1+2 

I F = I F + 1 
I F PI  = I F P2 

IF ( IFP1-NP2 1610,700, 700 
C 

C COMPLETE  A REAL  TRANSFORM  IN  THE  1ST  DIMENSION,  N EVEN,  BY  CON- 

C JUGATE  SYMMETRIES. 

C 

700  GO  TO  (900,800,900,701 ), ICASE 

701  NHALF=N 
N=  N+N 

THET  A=-TWCPI/FLOAT  (N) 

I F ( I S I GN ) 703 , 702,702 

702  THET  A= -THET A 

703  WSTPR=COS  (THET  A) 

WSTPI  = SIMTHET  A) 

VIR  = WST  PR 
WI=WSTPI 

I MI N=3 

J M I fs=  2 *NH  ILF-1 
GO  TO  725 
710  J=  JMI N 

DO  720  1= I MIN, NTOT  ,NP2 
SUMR=(UATA(I)+CATA(J))/2. 

SU  MI  = ( DAT  A(  I +1  I +DAT A ( J + 1 ) ) /2  . 

01 FR=( DAT A(  I I-OAT A( J ) )/2. 

0 1 F T - (DAT  A(  I + i )-DaTA(J  + 1)  )/2. 

TEMPR=WR*SUKI+W  I *D  I FR 
tfmpi=wi*sumi-wr*oifr 
DAI A( I ) = SUMR+T  EMPR 
DAT  A(  I +1  ) = D I ;I  +TEMP  I 
D AT  A ( J ) = SUMR-T  EMPR 
DAT  A(J+1)=-DIFI+TEMPI 
720  J = J + N P 2 

I M I N=  I MI  N+  2 
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HUL. 


' 


o 


JM I N=  J MIN-2 
TEMPR=WR 

WR=WR+rfSTPR-WI +WSTP I 
WI=TEMPR*WSTPI+W I • W S T P R 
725  IF (IMIN-JMINI710, 730,740 

730  IF  <ISIGN)731,740,740 

731  DO  735  I=IMIN,NTQT  * NP2 

735  DATA! I vl)=-OATA<  1+1  I 

740  NP2=NP2+NP2 

NT  CT  = NT  CT  + NTOT 
J=  NTOT  +1 
I MAX=N7 OT/  2 *■  1 
745  I MI  N=  I MAX -2+NHAL  F 
I = I MI  N 
GO  TO  755 

750  DATA!  J)=DATA<  I ) 

OAT  A(J+1)=-DAT  A<  I ♦ 1 » 

755  1=1+2 

J = J-2 

IF(I-IMAX)750,760,  760 
760  DATA!  JI  = CATA(  IMINI-CATAI  IN  IN  + 1) 

DATA! J+1)=0. 

IF ( I-J  1770, 780,780 
765  DAT  A( J I = DAT  A ( I I 

DATA!  J + 1»=CATA(  I+l) 

770  1=1-2 

J=  J-2 

IF ( I-IMINI775.775,  765 
775  DATA!  J»  = CATA<  IM  INI  +CATA(  IM  IM  + 1) 

DAT  A( J + I )=0. 

IMAX=IMIN 
GO  TO  745 

780  DAT  A(I)  = CATAi  1 I+DAT  A(  2) 

DAT  A ( 2 I =0 . 

GO  TO  900 
C 

C COMPLETE  A REAL  TRANSFORM  FOR  TPE  2ND  OR  3RD  DIMENSION  BY 

C CONJUGATE  SYMMETRIES. 

C 

800  I F ( I1RNG-NP1I805, 900,900 

805  DO  860  1 3= 1 1 NT OT  » NP 2 
I 2 MAX= 1 3+NP2-NP1 
DO  860  12=13, I2MAX.NPI 
IMIN=I2+IIRNG 
I MAX* 1 2 + NP1-2 
JMAX=2*I3+NP1-IMIN 
IF( 12-13/820,820,  810 
810  JMAX= JMAX+NP2 
820  I F ( IDIM-2<850,850,  830 
830  J=  JMAX+  NPO 

00  840  1=  I MIN,  IMAX,  2 
DAT  At  I I = 0 A1  A ( J ) 

DATA!  I+l  ) = -DAT  AC  J + 1 1 
840  J=  J-2 

850  J=  JMAX 

00  860  1= I MI N, IMAX, NPO 
OAT  A(  I t-OATAt J ) 

DATA!  I + l ) = -DAT  A(  J+l) 

860  J= J-NPO 
C 

C END  CF  LOCP  CN  EACH  DIM  CNS  I3N 

C 


1 


j 


177 


900  NP0=NP1 
NPi=NP2 
910  NPRfcV=  N 
920  RlTURN 
END 

SUBROU  T l NE  A I RY  ( A , B, X ) 

C 

C...  RUUTINL  TC  CALCULATE  AIRY  FUNCTION  AT  X 
C 

DI RENS IGN  ATABI67) , BTABI67 ), ADTAB! 67  ) , BDTAB ( 67 > , A A ( 11 ) 
DATA  PI/3.1415926535/,  Iks/O/ 

C 

C...  SET  UP  TAYLOR  TABLES 
C 

IF ( IW.NE.O)  GOTO  30 
I W = 1 

ATAB(67)=2.1565999525E-6 
ADTABI67 ) =-5,o 19 319442 E-6 
BT  ABI34  )=0.61Y>926o274 
BDT AB(  34  ) = 0. 448288  3574 
XT  A B = 0 . 

DO  10  1=34,66 

CALL  T AYLURI  B,8D,XTAB,  0.1,  BTAB(  I ),  BDTAB ( I ) ) 

CALL  TAYLOR!  fiT  A 0(1+1), BDTAB!  I + 1 ),  XTAB +0. 1 , 0. 1 , B , BD ) 

CALL  T AYLOR! B, »D,-XTAB, -0. 1,  BTAB! 68- I ), BDTAB (68- I ) ) 

CALL  T AYLCR(BT AB( 57-1 ) , BDT ABI67-I  ) , -X TAB-0. 1 ,-0. 1 ,B ,R0 ) 
XT  AB=  XT  AB+O .2 
10  CONTINUE 

DO  20  1=2,67 

CALL  7 AYLCR(A, AD, XT  A B, -0 . 1 , AT AB ( 69- I ),ADTAB(69-I ) ) 

CALL  T AYLOR!  AT  A9(  6 8-1  ),  ADTAB(68-I  ) , XTAB- 0. 1 ,-0. 1 , A , AD  ) 
XT  AB=XT  AB-0 .2 
20  CONTINUE 
C 

C...  '(  AYLOR  SERIES  EXPANSION 

C 

30  CONTINUE 

IF (ABS(X) .GT.6.6)  GOTO  40 
J=5.*X 

XT  A B=  FLOAT  ( J ) / 5 . 

H=X-XT  AB 

CALL  TAYLCR! A, AD, XTAB,  H, AT  AB ( 3 4+J ) , ADTAB ( 34+ J ) ) 

CALL  T AYLOR!  B,  BD,XTAB,  H,  BT  AB!  34+J  ),  BDTAB  ( 34+J  ) ) 

GOT  C 70 
C 

C...  ASYRPTOT'C  SOLUTION 
C 

40  CONTINUE 

RTMDX=SQRT( ABS (X ) ) 

XI=RTMDX*»3/ 1.5 
FACTOR= 1./ ( 12. *X I ) 

AA(1)=1./SQRT( PI+RTMDX ) 

R=6 . 

DO  50  1=1,10 

A A ( 1 + 1 )= ( R-l. ) *( R-5. )* FACTOR *A A!  I )/R 
R=  R+6 . 

50  CONTINUE 

IF (X.LT  .0.  ) GOTO  60 

P=AA( 1)+AA(3)  + AA(5)  + AA!  7)+AA( 9)+AA(  11) 

C=AA(2)+AA(4)  + AA(6)  + AA!8!+AA(10) 

SCALE=  EXP! XI ) 

A=  (P-0)/ (2.+SCALE) 
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non 


C 


0=  { P+Q  I *SC AL  E 
GOTO  70 


60  CONTINUE 

P=  AA(  1 )-AA{  3 > + A At  5 I-AAI  7I+AAI  9 I-AAI  11) 
C=AA(2)-AA<4)+AA<6>-AA<  8H-AAI  10) 

S=  S I N( X I + PI /4. I 
C=  COS (XI+PI/4. I 
A=  P»S-Q*C 
0=  P*C+Q*S 

70  CONTINUE 
RETURN 
END 

SUBROUTINE  TAYLORIYl.Dl.X,  H,  Y,D) 


...  SUBROUTINE  TO  CALCULATE  YIX+H)  FROM  YIX)  BY  SERIES  EXPANSION 


DI MENS  ION  TORI  11 ) 

C 

IFIH.NE.O.)  GOTO  10 
Y1  = Y 
Dl  = 0 
GOTO  30 
C 

10  CONTINUE 
TOR ( 1 ) * Y 
T0R(2)=H«C 
SQU ARE=H*H 

TORI3)  = .5*SOUARE*X*TOR 
Yl*TOR+TOR(2)+TOR(3) 

D1=T0R(2)+2.*TUR(3) 

DO  20  N=4 » 11 

TOR(N)  = SCUARE*(X*TOR(Y-2)+F*TOR(N-3) ) /(  I N-  1 ) * I N-  2 >) 
Y1 * Yl  + T OR ( N ) 

D1=D1+(N-1»*T0R(N) 

20  CONTINUE 
01  = Dl/ H 
C 

30  CONTINUE 
RETURN 
END 
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